packages feed

optparse-applicative 0.12.1.0 → 0.19.0.0

raw patch · 67 files changed

Files

CHANGELOG.md view
@@ -1,11 +1,288 @@-## Version 0.12.1.0 (18 Jan 2016)+## 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. -- Improve subparser contexts to improve usage error texts+- 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.++- Doc++## Version 0.13.1.0 (10 Feb 2017)++- Updated dependency bounds.++- Add required test files to cabal package.++- Doc++## Version 0.13.0.0 (15 Aug 2016)++- Implement command groups, which allow subcommands to have their own+  usage description.++- Implement showHelpOnEmpty, which is similar to showHelpOnError, but only+  fires when a command or subcommand is begun, and suppresses the "Missing:"+  error text.++- Fix ghc 8.0 warnings.++- Fix ghc 7.10 warnings.++- Bump dependency bounds.++- Add maybeReader function for convenient ReadM creation.++- Move eitherReader to Readers section (for better discoverability).++- Fix hsubparser metavar override.++- Remove ComplError, which was dead code.++- Reimplement Missing error generation, which overly complicated evalParser.++- Export Semigroup instances for types which are also Monoids. Removes+  mempty synonym `(<>)` export, as it clashes with Semigroup exports.+  One may need to import Data.Monoid or Data.Semigroup when upgrading.++- Use a Cabal test suite for tests, simplify test dependencies.++## Version 0.12.1.0 (18 Jan 2016)++- Updated dependency bounds.++- Improve subparser contexts to improve usage error texts.++- Docs.+ - Fixed bugs     * \# 164 - Invalid options and invalid arguments after parser has succeeded                not displaying@@ -24,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. @@ -122,7 +399,7 @@  ## Version 0.7.0.1 (18 Oct 2013) -- Minor docs fixes+- Minor docs fixes.  ## Version 0.7.0 (17 Oct 2013) @@ -150,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@@ -174,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. @@ -190,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. @@ -281,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,91 +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 ((<$>), (<*>), many)-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,400 +0,0 @@-{-# 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,-  nullOption,--  -- * Modifiers-  short,-  long,-  help,-  helpDoc,-  value,-  showDefaultWith,-  showDefault,-  metavar,-  eitherReader,-  noArgError,-  ParseError(..),-  hidden,-  internal,-  command,-  completeWith,-  action,-  completer,-  idm,-#if __GLASGOW_HASKELL__ > 702-  (<>),-#endif-  mappend,--  -- * Readers-  ---  -- | A collection of basic 'Option' readers.-  auto,-  str,-  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,-  noBacktrack,-  columns,-  prefs,-  defaultPrefs,--  -- * Types-  Mod,-  ReadM,-  OptionFields,-  FlagFields,-  ArgumentFields,-  CommandFields-  ) where--import Control.Applicative (pure, (<|>))-import Data.Monoid (Monoid (..)-#if __GLASGOW_HASKELL__ > 702-  , (<>)-#endif-  )--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---- | 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.-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 }---- | Convert a function in the 'Either' monad to a reader.-eitherReader :: (String -> Either String a) -> ReadM a-eitherReader f = readerAsk >>= either readerError return . f---- | Specify the error to display when no argument is provided to this option.-noArgError :: ParseError -> Mod OptionFields a-noArgError e = fieldMod $ \p -> p { optNoArgError = e }---- | 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 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-    rdr = uncurry CmdReader (mkCommand m)---- | 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.-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.-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.------ > 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.-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 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 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 }--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-      , 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,30 +0,0 @@-module Options.Applicative.Builder.Completer-  ( Completer-  , mkCompleter-  , listIOCompleter-  , listCompleter-  , bashCompleter-  ) where--import Control.Applicative ((<$>), pure)-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,172 +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 (pure, (<*>), empty, (<|>))-import Control.Monad (mplus)-import Data.Monoid (Monoid(..))--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)] }--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 (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-  Mod f1 d1 g1 `mappend` Mod f2 d2 g2-    = Mod (f2 . f1) (d2 `mappend` d1) (g2 . g1)---- | Base default properties.-baseProps :: OptProperties-baseProps = OptProperties-  { propMetaVar = ""-  , propVisibility = Visible-  , propHelp = mempty-  , propShowDefault = Nothing }--mkCommand :: Mod CommandFields a -> ([String], String -> Maybe (ParserInfo a))-mkCommand m = (map fst cmds, (`lookup` cmds))-  where-    Mod f _ _ = m-    CommandFields cmds = f (CommandFields [])--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,369 +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,-  optDesc,-  OptDescStyle (..)-  ) where--import Control.Applicative (pure, (<*>), (<*), (*>), (<$>), (<|>), (<$))-import Control.Arrow (left)-import Control.Monad (guard, mzero, msum, when, liftM)-import Control.Monad.Trans.Class (lift)-import Control.Monad.Trans.State (StateT(..), get, put, runStateT)-import Data.List (isPrefixOf, sort, intersperse)-import Data.Maybe (maybeToList)-import Data.Monoid (Monoid(..))--import Options.Applicative.Internal-import Options.Applicative.Types--import Options.Applicative.Help.Pretty-import Options.Applicative.Help.Chunk--showOption :: OptName -> String-showOption (OptLong n) = "--" ++ n-showOption (OptShort n) = '-' : [n]--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--data MatchResult-  = NoMatch-  | Match (Maybe String)--instance Monoid MatchResult where-  mempty = NoMatch-  mappend m@(Match _) _ = m-  mappend _ m = m--argMatches :: MonadP m => OptReader a -> String-           -> Maybe (StateT Args m a)-argMatches opt arg = case opt of-  ArgReader rdr -> Just $ do-    result <- lift $ runReadM (crReader rdr) arg-    return result-  CmdReader _ f ->-    flip fmap (f arg) $ \subp -> StateT $ \args -> do-      prefs <- getPrefs-      let runSubparser-            | prefBacktrack prefs = \i a ->-                runParser (getPolicy i) (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-             => ParserPrefs-             -> (forall r . Option r -> NondetT m r)-             -> Parser a -> NondetT m (Parser a)-searchParser _ _ (NilP _) = mzero-searchParser _ f (OptP opt) = liftM pure (f opt)-searchParser pprefs f (MultP p1 p2) = foldr1 (<!>)-  [ do p1' <- searchParser pprefs f p1-       return (p1' <*> p2)-  , do p2' <- searchParser pprefs f p2-       return (p1 <*> p2') ]-searchParser pprefs f (AltP p1 p2) = msum-  [ searchParser pprefs f p1-  , searchParser pprefs f p2 ]-searchParser pprefs f (BindP p k) = do-  p' <- searchParser pprefs f p-  case (evalParser False False (optDesc pprefs missingStyle) p') of-    Left _ -> mzero-    Right aa -> pure $ k aa--searchOpt :: MonadP m => ParserPrefs -> OptWord -> Parser a-          -> NondetT (StateT Args m) (Parser a)-searchOpt pprefs w = searchParser pprefs $ \opt -> do-  let disambiguate = prefDisambiguate pprefs-                  && optVisibility opt > Internal-  case optMatches disambiguate (optMain opt) w of-    Just matcher -> lift matcher-    Nothing -> mzero--searchArg :: MonadP m => ParserPrefs -> String -> Parser a-          -> NondetT (StateT Args m) (Parser a)-searchArg pprefs arg = searchParser pprefs $ \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 pprefs arg p-stepParser pprefs AllowOpts arg p = msum-  [ searchArg pprefs arg p-  , do w <- hoistMaybe (parseWord arg)-       searchOpt pprefs w p ]---- | Apply a 'Parser' to a command line, and return a result and leftover--- arguments.  This function returns an error if any parsing error occurs, or--- if any options are missing and don't have a default value.-runParser :: MonadP m => ArgPolicy -> Parser a -> Args -> m (a, Args)-runParser SkipOpts p ("--" : argt) = runParser AllowOpts p argt-runParser policy p args = case args of-  [] -> do-    prefs <- getPrefs-    exitP p $ MissingError `left` result prefs-  (arg : argt) -> do-    prefs <- getPrefs-    (mp', args') <- do_step prefs arg argt-    case mp' of-      Nothing -> hoistEither (MissingError `left` (result prefs)) <|> parseError arg-      Just p' -> runParser policy p' args'-  where-    result (prefs') = (,) <$> evalParser False False (optDesc prefs' missingStyle) 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 p args-  case args' of-    []  -> return r-    a:_ -> parseError a---- | The default value of a 'Parser'.  This function returns an error if any of--- the options don't have a default value.-evalParser :: Bool -> Bool-        -> (forall x . OptHelpInfo -> Option x -> b)-        -> Parser a-        -> Either (OptTree b) a-evalParser _ _ _ (NilP r) = maybeToEither (MultNode []) r-evalParser m d f (OptP opt)-      | optVisibility opt > Internal-      = Left $ Leaf (f (OptHelpInfo m d) opt)-      | otherwise-      = Left $ MultNode []-evalParser m d f (MultP p1 p2) = case (evalParser m d f p1, evalParser m d f p2) of-  (Right a', Right b') -> Right $ a' b'-  (Left a', Left b')   -> Left $ MultNode [a', b']-  (Left a', _)         -> Left $ MultNode [a']-  (_, Left b')         -> Left $ MultNode [b']-evalParser m d f (AltP p1 p2) = case (evalParser m d f p1, evalParser m d f p2) of-  (Right a', _)        -> Right a'-  (_, Right b')        -> Right b'-  (Left a', Left b')   -> Left $ AltNode [a', b']-evalParser _ d f (BindP p k) = evalParser True d f p >>= (evalParser True d f) . k---- | 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 = either (const False) (const True) (evalParser False False g 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]----- | Style for rendering an option.-data OptDescStyle = OptDescStyle-  { descSep :: Doc-  , descHidden :: Bool-  , descSurround :: Bool }---- | Generate description for a single option.-optDesc :: ParserPrefs -> OptDescStyle -> OptHelpInfo -> Option a -> Chunk Doc-optDesc pprefs style info opt =-  let ns = optionNames $ optMain opt-      mv = stringChunk $ optMetaVar opt-      descs = map (string . showOption) (sort ns)-      desc' = listToChunk (intersperse (descSep style) descs) <<+>> mv-      show_opt-        | optVisibility opt == Hidden-        = descHidden style-        | otherwise-        = optVisibility opt == Visible-      suffix-        | hinfoMulti info-        = stringChunk . prefMultiSuffix $ pprefs-        | otherwise-        = mempty-      render chunk-        | not show_opt-        = mempty-        | isEmpty chunk || not (descSurround style)-        = mappend chunk suffix-        | hinfoDefault info-        = mappend (fmap brackets chunk) suffix-        | null (drop 1 descs)-        = mappend chunk suffix-        | otherwise-        = mappend (fmap parens chunk) suffix-  in render desc'--missingStyle :: OptDescStyle-missingStyle = OptDescStyle-  { descSep = string "|"-  , descHidden = False-  , descSurround = True }--maybeToEither :: b -> Maybe a -> Either b a-maybeToEither = flip maybe Right . Left
− Options/Applicative/Extra.hs 
@@ -1,192 +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 (pure, (<$>), (<|>), (<**>))-import Data.Monoid (mempty, mconcat)-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 = m `mappend` metavar "COMMAND"-    (cmds, subs) = mkCommand m-    rdr = CmdReader 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 x -> stringChunk "Missing:" <<+>> fold_tree 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-      _            -> 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,8 +0,0 @@-module Options.Applicative.Help (-  module X-  ) where--import Options.Applicative.Help.Pretty as X-import Options.Applicative.Help.Chunk as X-import Options.Applicative.Help.Types as X-import Options.Applicative.Help.Core as X
− Options/Applicative/Help/Chunk.hs 
@@ -1,139 +0,0 @@-{-# LANGUAGE CPP #-}-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 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,108 +0,0 @@-module Options.Applicative.Help.Core (-  cmdDesc,-  briefDesc,-  fold_tree,-  fullDesc,-  ParserHelp(..),-  errorHelp,-  headerHelp,-  usageHelp,-  bodyHelp,-  footerHelp,-  parserHelp,-  parserUsage,-  ) where--import Control.Monad (guard)-import Data.Maybe (maybeToList, catMaybes)-import Data.Monoid (mempty)--import Options.Applicative.Common-import Options.Applicative.Types-import Options.Applicative.Help.Pretty-import Options.Applicative.Help.Chunk---- | Generate descriptions for commands.-cmdDesc :: Parser a -> Chunk Doc-cmdDesc = vcatChunks . mapParser desc-  where-    desc _ opt =-      case optMain opt of-        CmdReader cmds p ->-          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 pprefs = fold_tree . treeMapParser (optDesc pprefs style)-  where-    style = OptDescStyle-      { descSep = string "|"-      , descHidden = False-      , 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-      , 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)-  , with_title "Available commands:" (cmdDesc p) ]-  where-    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,36 +0,0 @@-module Options.Applicative.Help.Types (-  ParserHelp(..),-  renderHelp-  ) where--import Data.Monoid--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 (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,281 +0,0 @@-{-# LANGUAGE ExistentialQuantification #-}-module Options.Applicative.Internal-  ( P-  , Context(..)-  , MonadP(..)-  , ParseError(..)--  , uncons-  , hoistMaybe-  , hoistEither-  , runReadM-  , withReadM--  , runP--  , Completion-  , runCompletion-  , SomeParser(..)-  , ComplError(..)-  , contextNames--  , ListT-  , takeListT-  , runListT--  , NondetT-  , cut-  , (<!>)-  , disamb-  ) where--import Control.Applicative (Applicative(..), Alternative(..), (<$>))-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 :: Parser b -> Either ParseError 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---data Context-  = forall a . Context String (ParserInfo a)--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 _ = P . (either throwE 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 SomeParser = forall a . SomeParser (Parser a)--data ComplError-  = ComplParseError String-  | ComplExit--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,327 +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(..),--  fromM,-  oneM,-  manyM,-  someM,--  optVisibility,-  optMetaVar,-  optHelp,-  optShowDefault-  ) where--import Control.Applicative-  (Applicative(..), Alternative(..), (<$>), optional)-import Control.Monad (ap, liftM, MonadPlus, mzero, mplus)-import Control.Monad.Trans.Except (Except, throwE)-import Control.Monad.Trans.Class (lift)-import Control.Monad.Trans.Reader (ReaderT, ask)-import Data.Monoid (Monoid(..))-import System.Exit (ExitCode(..))--import Options.Applicative.Help.Types-import Options.Applicative.Help.Pretty-import Options.Applicative.Help.Chunk--data ParseError-  = ErrorMsg String-  | InfoMsg String-  | ShowHelpText-  | UnknownError-  | MissingError (OptTree (Chunk Doc))-  deriving Show--instance Monoid ParseError where-  mempty = UnknownError-  mappend m UnknownError = m-  mappend _ 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)-  , 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-  }--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 [String] (String -> Maybe (ParserInfo a)) -- ^ command reader--instance Functor OptReader where-  fmap f (OptReader ns cr e) = OptReader ns (fmap f cr) e-  fmap f (FlagReader ns x) = FlagReader ns (f x)-  fmap f (ArgReader cr) = ArgReader (fmap f cr)-  fmap f (CmdReader cs g) = CmdReader cs ((fmap . fmap) f . g)---- | 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]--data ArgPolicy-  = SkipOpts-  | AllowOpts-  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
@@ -1,367 +1,1088 @@-# Applicative option parser--This package contains utilities and combinators to define command line option-parsers.--[![Continuous Integration status][status-png]][status]-[![Hackage page (downloads and API reference)][hackage-png]][hackage]--**Table of Contents**--- [Getting started](#getting-started)-- [Supported options](#supported-options)-    - [Regular options](#regular-options)-    - [Flags](#flags)-    - [Arguments](#arguments)-    - [Commands](#commands)-- [Option builders](#option-builders)-- [Advanced features](#advanced-features)-- [How it works](#how-it-works)--## Getting started--Install with--```sh-cabal install optparse-applicative-```--Here is a simple example of an applicative option parser:--```haskell-import Options.Applicative--data Sample = Sample-  { hello :: String-  , quiet :: Bool }--sample :: Parser Sample-sample = Sample-     <$> strOption-         ( long "hello"-        <> metavar "TARGET"-        <> help "Target for the greeting" )-     <*> switch-         ( long "quiet"-        <> help "Whether to be quiet" )-```--The parser is built using [applicative style][applicative] 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`).--A parser can be used like this:--```haskell-greet :: Sample -> IO ()-greet (Sample h False) = putStrLn $ "Hello, " ++ h-greet _ = return ()--main :: IO ()-main = execParser opts >>= greet-  where-    opts = info (helper <*> sample)-      ( fullDesc-     <> progDesc "Print a greeting for TARGET"-     <> header "hello - a test for optparse-applicative" )-```--The `greet` function is the entry point of the program, while `opts` is a-complete description of the program, used when generating a help text. The-`helper` combinator takes any parser, and adds a `help` option to it.--The `hello` option in this example is mandatory (since it doesn't have a-default value), so running the program without any argument will display a-short option summary:--    Usage: hello --hello TARGET [--quiet]--Running the program with the `--help` option will display the full help text:--    hello - a test for optparse-applicative--    Usage: hello --hello TARGET [--quiet]-      Print a greeting for TARGET--    Available options:-      -h,--help                Show this help text-      --hello TARGET           Target for the greeting-      --quiet                  Whether to be quiet--containing a detailed list of options with descriptions.--The specified metavars are used as placeholders for the option arguments, and-can be referred to in the program description.  This makes it possible to-explicitly describe the connection between the options and the behaviour of the-program.--Parsers are instances of both `Applicative` and `Alternative`, and work with-any generic combinator, like `many` and `some`. For example, to make a option-return `Nothing` instead of failing when it's not supplied, you can use the-`optional` combinator in `Control.Applicative`:--```haskell-optional $ strOption-   ( long "output"-  <> metavar "DIRECTORY" )-```-- [applicative]: http://www.soi.city.ac.uk/~ross/papers/Applicative.html--## Supported options--`optparse-applicative` supports four kinds of options: regular options, flags,-arguments and commands.--### Regular options--A **regular option** is an option which takes a single argument, parses it, and-returns a value.--A regular option can have a default value, which is used as the result if the-option is not found in the command line. An option without a default value is-considered mandatory, and produces an error when not found.--Regular options can have **long** names, or **short** (one-character) names,-which determine when the option matches and how the argument is extracted.--An option with a long name (say "output") is specified on the command line as--    --output filename.txt--or--    --output=filename.txt--while a short name option (say "o") can be specified with--    -o filename.txt--or--    -ofilename.txt--Options can have more than one name, usually one long and one short, although-you are free to create options with an arbitrary combination of long and short-names.--Regular options returning strings are the most common, and they can be created-using the `strOption` builder. For example,--```haskell-strOption-   ( long "output"-  <> short 'o'-  <> metavar "FILE"-  <> help "Write output to FILE" )-```--creates a regular option with a string argument (which can be referred to as-`FILE` in the help text and documentation), a long name "output" and a short-name "o". See below for more information on the builder syntax and modifiers.--A regular option can return an object of any type, and takes a *reader*-parameter which specifies how the argument should be parsed.  A common reader is-`auto`, which assumes a `Read` instance for the return type and uses it to parse-its argument. For example:--```haskell-lineCount :: Parser Int-lineCount = option auto-            ( long "lines"-           <> short 'n'-           <> metavar "K"-           <> help "Output the last K lines" )-```--specifies a regular option with an `Int` argument. We added an explicit type-annotation here, since without it the parser would have been polymorphic in the-output type. There's usually no need to add type annotations, however, because-the type will be normally inferred from the context in which the parser is-used.--You can also create a custom reader that doesn't use the `Read` typeclass, and-use it to parse option arguments.  A custom reader is a value in the `ReadM`-monad.--```haskell-data FluxCapacitor = ...--parseFluxCapacitor :: Monad m => String -> m FluxCapacitor--option (str >>= parseFluxCapacitor)-  ( long "flux-capacitor" )-```--Use `readerAbort` or `readerError` within the `ReadM` monad to exit with an-error message.--### Flags--A **flag** is just like a regular option, but it doesn't take any arguments: it is-either present in the command line or not.--A flag has a default value and an **active value**. If the flag is found on the-command line, the active value is returned, otherwise the default value is-used. For example:--```haskell-data Verbosity = Normal | Verbose--flag Normal Verbose-  ( long "verbose"- <> short 'v'- <> help "Enable verbose mode" )-```--is a flag parser returning a `Verbosity` value.--Simple boolean flags can be specified using the `switch` builder, like so:--```haskell-switch-  ( long "keep-tmp-files"- <> help "Retain all intermediate temporary files" )-```--There is also a `flag'` builder, which has no default value. For example, to-add a `--version` switch to a program, you could write:--```haskell-flag' Nothing (long "version" <> hidden) <|> (Just <$> normal_options)-```--### Arguments--An **argument** parser specifies a positional command line argument.--The `argument` builder takes a reader parameter, and creates a parser which-will return the parsed value every time it is passed a command line argument-for which the reader succeeds. For example--```haskell-argument str (metavar "FILE")-```--creates an argument accepting any string.  To accept an arbitrary number of-arguments, combine the `argument` builder with either the `many` or `some`-combinator:--```haskell-some (argument str (metavar "FILES..."))-```--Arguments are only displayed in the brief help text, so there's no need to-attach a description to them. They should be manually documented in the program-description.--Note that arguments starting with `-` are considered options by default, and-will not be considered by an `argument` parser.--However, parsers always accept a special argument: `--`. When a `--` is found on-the command line, all the following words are considered by `argument` parsers,-regardless of whether they start with `-` or not.--### Commands--A **command** can be used to specify a sub-parser to be used when a certain-string is encountered in the command line.--Commands are useful to implement command line programs with multiple functions,-each with its own set of options, and possibly some 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, 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, for the parser above, you would-define a type like:--```haskell-data Options = Options-  { optGlobalOpt :: String-  , optGlobalFlag :: Bool-  ...-  , optCommand :: Command }--data Command-  = Add AddOptions-  | Commit CommitOptions-  ...-```--Alternatively, you can directly return an `IO` action from a parser, and-execute it using `join` from `Control.Monad`.--```haskell-start :: String -> IO ()-stop :: IO ()--opts :: Parser (IO ())-opts = subparser-  ( command "start" (info (start <$> argument str idm) idm)- <> command "stop"  (info (pure stop) idm) )--main :: IO ()-main = join $ execParser (info opts idm)-```--## Option builders--Builders allow you to define parsers using a convenient combinator-based-syntax. Each builder takes a **modifier** as parameter, and returns a parser.--A modifier is a composition of functions which act on the option, setting-values for properties or adding features, and is used to build the option from-scratch and finally lift it to a single-option parser, which can then be-combined with other parsers using normal `Applicative` combinators.--Modifiers are instances of the `Monoid` typeclass, so they can be combined-using the composition function `mappend` (or simply `(<>)`).--See the [haddock documentation][builder-documentation] for `Options.Applicative.Builder`-for a full list of builders and modifiers.--## Advanced features--* [Bash completion]-* [Arrow interface]-* [Disambiguation]-- [Bash completion]: https://github.com/pcapriotti/optparse-applicative/wiki/Bash-Completion- [Arrow interface]: https://github.com/pcapriotti/optparse-applicative/wiki/Arrows- [Disambiguation]: https://github.com/pcapriotti/optparse-applicative/wiki/Disambiguation--## How it works--A `Parser a` is essentially a heterogeneous list of `Option`s, implemented with-existential types.--All options are therefore known statically (i.e. before parsing, not-necessarily before runtime), and can, for example, be traversed to generate a-help text.--See [this blog post][blog] for a more detailed explanation based on a-simplified implementation.-- [status-png]: https://api.travis-ci.org/pcapriotti/optparse-applicative.svg- [status]: http://travis-ci.org/pcapriotti/optparse-applicative?branch=master- [blog]: http://paolocapriotti.com/blog/2012/04/27/applicative-option-parser/- [builder-documentation]: http://hackage.haskell.org/package/optparse-applicative/docs/Options-Applicative-Builder.html- [hackage-png]: http://img.shields.io/hackage/v/optparse-applicative.svg- [hackage]: http://hackage.haskell.org/package/optparse-applicative+# optparse-applicative++[![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, 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, zsh, and fish completions.++**Table of Contents**++- [Introduction](#introduction)+- [Quick Start](#quick-start)+- [Basics](#basics)+    - [Parsers](#parsers)+    - [Applicative](#applicative)+    - [Alternative](#alternative)+    - [Running parsers](#running-parsers)+- [Builders](#builders)+    - [Regular options](#regular-options)+    - [Flags](#flags)+    - [Arguments](#arguments)+    - [Commands](#commands)+    - [Modifiers](#modifiers)+- [Custom parsing and error handling](#custom-parsing-and-error-handling)+    - [Parser runners](#parser-runners)+    - [Option readers](#option-readers)+    - [Preferences](#preferences)+    - [Disambiguation](#disambiguation)+    - [Customising the help screen](#customising-the-help-screen)+    - [Command Groups](#command-groups)+- [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++The core type in optparse-applicative is a `Parser`++```haskell+data Parser a++instance Functor Parser+instance Applicative Parser+instance Alternative Parser+```++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.++If you are familiar with parser combinator libraries like [parsec],+[attoparsec], or the json parser [aeson] you will feel right at+home with optparse-applicative.++If not, don't worry! All you really need to learn are a few basic+parsers, and how to compose them as instances of `Applicative` and+`Alternative`.++## Quick Start++Here's a simple example of a parser.++```haskell+import Options.Applicative++data Sample = Sample+  { hello      :: String+  , quiet      :: Bool+  , enthusiasm :: Int }++sample :: Parser Sample+sample = Sample+      <$> strOption+          ( long "hello"+         <> metavar "TARGET"+         <> help "Target for the greeting" )+      <*> switch+          ( long "quiet"+         <> short 'q'+         <> help "Whether to be quiet" )+      <*> option auto+          ( long "enthusiasm"+         <> help "How enthusiastically to greet"+         <> showDefault+         <> value 1+         <> metavar "INT" )+```++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 a switch) and enthusiasm gets parsed as an `Int` with help+of the `Read` type class.+++The parser can be used like this:++```haskell+main :: IO ()+main = greet =<< execParser opts+  where+    opts = info (sample <**> helper)+      ( fullDesc+     <> progDesc "Print a greeting for TARGET"+     <> header "hello - a test for optparse-applicative" )++greet :: Sample -> IO ()+greet (Sample h False n) = putStrLn $ "Hello, " ++ h ++ replicate n '!'+greet _ = return ()+```++The `greet` function is the entry point of the program, while `opts`+is a complete description of the program, used when generating a+help text. The `helper` combinator takes any parser, and adds a+`help` option to it.++The `hello` option in this example is mandatory since it doesn't+have a default value, so running the program without any argument+will display an appropriate error message and a short option summary:++    Missing: --hello TARGET++    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+containing a detailed list of options with descriptions++```+    hello - a test for optparse-applicative++    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+      --enthusiasm INT         How enthusiastically to greet (default: 1)+      -h,--help                Show this help text+```++## Basics+### Parsers++optparse-applicative provides a number of primitive parsers,+corresponding to different posix style options, through its *Builder*+interface. These are detailed in their [own section](#builders)+below, for now, here's a look at a few more examples to get a feel+for how parsers can be defined.+++Here is a parser for a mandatory option with an argument:++```haskell+target :: Parser String+target = strOption+  (  long "hello"+  <> metavar "TARGET"+  <> help "Target for the greeting" )+```++One can see that we are defining an option parser for a `String`+argument, with *long* option name "hello", *metavariable* "TARGET",+and the given help text. This means that the `target` parser defined+above will require an option like++    --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+of the parser.++The attributes passed to the option are called *modifiers*, and are+composed using the [semigroup] operation `(<>)`.++Options with an argument such as `target` are referred to as *regular+options*, and are very common.  Another type of option is a *flag*,+the simplest of which is a boolean *switch*, for example:++```haskell+quiet :: Parser Bool+quiet = switch ( long "quiet" <> short 'q' <> help "Whether to be quiet" )+```++Here we used a `short` modifier to specify a one-letter name for+the option.  This means that this switch can be set either with+`--quiet` or `-q`.++Flags, unlike regular options, have no arguments. They simply return+a predetermined value. For the simple switch above, this is `True`+if the user types the flag, and `False` otherwise.++There are other kinds of basic parsers, and several ways to configure+them.  These are covered in the [Builders](#builders) section.++### Applicative++Now we may combine the `target` and `quiet` into a single parser that+accepts both options and returns a combined value. Given a type++```haskell+data Options = Options+  { optTarget :: String+  , optQuiet :: Bool }+```++and now it's just a matter of using `Applicative`'s apply operator `(<*>)`+to combine the two previously defined parsers++```haskell+opts :: Parser Options+opts = Options <$> target <*> quiet+```++No matter which parsers appear first in the sequence, options will+still be parsed in whatever order they appear in the command line.+A parser with such a property is sometimes called a *permutation+parser*.++In our example, a command line like:++    --target world -q++will give the same result as++    -q --target world++It is this property which leads us to an Applicative interface+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+significant, in that it affects the generated help text. Customisation+can be achieved easily through a lambda abstraction, with [Arrow+notation](#arrow-interface), or by taking advantage of GHC 8's+[ApplicativeDo](#applicative-do) extension.++### Alternative++It is also common to find programs that can be configured in different+ways through the command line.  A typical example is a program that+can be given a text file as input, or alternatively read it directly+from the standard input.++We can model this easily and effectively in Haskell using *sum types*:++```haskell+data Input+  = FileInput FilePath+  | StdInput++run :: Input -> IO ()+run = ...+```++We can now define two basic parsers for the components of the sum type:++```haskell+fileInput :: Parser Input+fileInput = FileInput <$> strOption+  (  long "file"+  <> short 'f'+  <> metavar "FILENAME"+  <> help "Input file" )++stdInput :: Parser Input+stdInput = flag' StdInput+  (  long "stdin"+  <> help "Read from stdin" )+```++As the `Parser` type constructor is an instance of `Alternative`, we can+compose these parsers with a choice operator `(<|>)`++```haskell+input :: Parser Input+input = fileInput <|> stdInput+```++Now `--file "foo.txt"` will be parsed as `FileInput "foo.txt"`, `--stdin`+will be parsed as `StdInput`, but a command line containing both options,+like++    --file "foo.txt" --stdin++will be rejected.++Having `Applicative` and `Alternative` instances, optparse-applicative+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`. 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`+structure, that specifies a number of properties that only apply+to top level parsers, such as a header describing what the program+does, to be displayed in the help screen.++The function `info` will help with this step.  In the [Quick Start](#quick-start)+we saw++```haskell+opts :: ParserInfo Sample+opts = info (sample <**> helper)+  ( fullDesc+  <> progDesc "Print a greeting for TARGET"+  <> header "hello - a test for optparse-applicative" )+```++The `helper` parser that we added after `opts` just creates a dummy+`--help` option that displays the help text.  Besides that, we just+set some of the fields of the `ParserInfo` structure with meaningful+values.  Now that we have a `ParserInfo`, we can finally run the+parser.  The simplest way to do so is to simply call the `execParser`+function in your `main`:++```haskell+main :: IO ()+main = do+  options <- execParser opts+  ...+```++The `execParser` function takes care of everything, including getting+the arguments from the command line, displaying errors and help+screens to the user, and exiting with an appropriate exit code.++There are other ways to run a `ParserInfo`, in situations where you+need finer control over the behaviour of your parser, or if you+want to use it in pure code. They will be covered in [Custom parsing+and error handling](#custom-parsing-and-error-handling).++## Builders++Builders allow you to define parsers using a convenient combinator-based+syntax. We have already seen examples of builders in action, like+`strOption` and `switch`, which we used to define the `opts` parser+for our "hello" example.++Builders always take a [modifier](#modifiers) argument, which is+essentially a composition of functions acting on the option, setting+values for properties or adding features.++Builders work by building the option from scratch, and eventually+lifting it to a single-option parser, ready to be combined with+other parsers using normal `Applicative` and `Alternative` combinators.++See the [haddock documentation][hackage] for `Options.Applicative.Builder`+for a full list of builders and modifiers.++There are four different kinds of options in `optparse-applicative`:+regular options, flags, arguments, and commands. In the following,+we will go over each one of these and describe the builders that+can be used to create them.++### Regular options++A *regular option* is an option which takes a single argument,+parses it, and returns a value.++A regular option can have a default value, which is used as the+result if the option is not found in the command line. An option+without a default value is considered mandatory, and produces an+error when not found.++Regular options can have *long* names, or *short* (one-character)+names, which determine when the option matches and how the argument+is extracted.++An option with a long name (say "output") is specified on the command+line as+++    --output filename.txt++or++    --output=filename.txt++while a short name option (say "o") can be specified with++    -o filename.txt++or++    -ofilename.txt++Options can have more than one name, usually one long and one short,+although you are free to create options with an arbitrary combination+of long and short names.++Regular options returning strings are the most common, and they can+be created using the `strOption` builder. For example,++```haskell+strOption+   ( long "output"+  <> short 'o'+  <> metavar "FILE"+  <> value "out.txt"+  <> help "Write output to FILE" )+```++creates a regular option with a string argument (which can be+referred to as `FILE` in the help text and documentation), default+value "out.txt", a long name "output" and a short name "o".++A regular `option` can return an object of any type, and takes a+*reader* parameter which specifies how the argument should be parsed.+A common reader is `auto`, which requires a `Read` instance for the+return type and uses it to parse its argument. For example:++```haskell+lineCount :: Parser Int+lineCount = option auto+            ( long "lines"+           <> short 'n'+           <> metavar "K"+           <> help "Output the last K lines" )+```++specifies a regular option with an `Int` argument. We added an+explicit type annotation here, since without it the parser would+have been polymorphic in the output type. There's usually no need+to add type annotations, however, because the type will be normally+inferred from the context in which the parser is used.++Further information on *readers* is available [below](#option-readers).++### Flags++A *flag* is just like a regular option, but it doesn't take any+arguments, it is either present in the command line or not.++A flag has a default value and an *active value*. If the flag is+found on the command line, the active value is returned, otherwise+the default value is used. For example:++```haskell+data Verbosity = Normal | Verbose++flag Normal Verbose+  ( long "verbose"+ <> short 'v'+ <> help "Enable verbose mode" )+```++is a flag parser returning a `Verbosity` value.++Simple boolean flags can be specified using the `switch` builder, like so:++```haskell+switch+  ( long "keep-tmp-files"+ <> help "Retain all intermediate temporary files" )+```++There is also a `flag'` builder, which has no default value. This+was demonstrated earlier for our `--stdin` flag example, and is+usually used as one side of an alternative.++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 will+count the number of instances of `-v` on the command line.++```haskell+length <$> many (flag' () (short 'v'))+```++Flags can be used together after a single hyphen, so  `-vvv` and+`-v -v -v` will both yield 3 for the above parser.++### Arguments++An *argument* parser specifies a positional command line argument.++The `argument` builder takes a reader parameter, and creates a+parser which will return the parsed value every time it is passed+a command line argument for which the reader succeeds. For example++```haskell+argument str (metavar "FILE")+```++creates an argument accepting any string.  To accept an arbitrary+number of arguments, combine the `argument` builder with either the+`many` or `some` combinator:++```haskell+some (argument str (metavar "FILES"))+```++Note that arguments starting with `-` are considered options by+default, and will not be considered by an `argument` parser.++However, parsers always accept a special argument: `--`. When a+`--` is found on the command line, all the following words are+considered by `argument` parsers, regardless of whether they start+with `-` or not.++Arguments use the same *readers* as regular options.++### Commands++A *command* can be used to specify a sub-parser to be used when a+certain string is encountered in the command line.++Commands are useful to implement command line programs with multiple+functions, each with its own set of options, and possibly some+global options that apply to all of them. Typical examples are+version control systems like `git`, or build tools like `cabal`.++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,+for the parser above, you would define a type like:++```haskell+data Options = Options+  { optCommand :: Command+  , ... }++data Command+  = Add AddOptions+  | Commit CommitOptions+  ...+```++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`.++```haskell+start :: String -> IO ()+stop :: IO ()++opts :: Parser (IO ())+opts = hsubparser+  ( command "start" (info (start <$> argument str idm) idm)+ <> command "stop"  (info (pure stop) idm) )++main :: IO ()+main = join $ execParser (info opts idm)+```++### Modifiers++*Modifiers* are instances of the `Semigroup` and `Monoid` typeclasses,+so they can be combined using the composition function `mappend`+(or simply `(<>)`).  Since different builders accept different sets+of modifiers, modifiers have a type parameter that specifies which+builders support it.++For example,++```haskell+command :: String -> ParserInfo a -> Mod CommandFields a+```++can only be used with [commands](#commands), as the `CommandFields`+type argument of `Mod` will prevent it from being passed to builders+for other types of options.++Many modifiers are polymorphic in this type argument, which means+that they can be used with any builder.++## Custom parsing and error handling++### Parser runners+Parsers are run with the `execParser` family of functions — from+easiest to use to most flexible these are:++```haskell+execParser       :: ParserInfo a -> IO a+customExecParser :: ParserPrefs -> ParserInfo a -> IO a+execParserPure   :: ParserPrefs -> ParserInfo a -> [String] -> ParserResult a+```++When using the `IO` functions, retrieving command line arguments+and handling exit codes and failure will be done automatically.+When using `execParserPure`, the functions++```haskell+handleParseResult :: ParserResult a -> IO a+overFailure :: (ParserHelp -> ParserHelp) -> ParserResult a -> ParserResult a+```++can be used to correctly set exit codes and display the help message;+and modify the help message in the event of a failure (adding+additional information for example).++### Option readers++Options and Arguments require a way to interpret the string passed+on the command line to the type desired. The `str` and `auto`+*readers* are the most common way, but one can also create a custom+reader that doesn't use the `Read` type class or return a `String`,+and use it to parse the option. A custom reader is a value in the+`ReadM` monad.++We provide the `eitherReader :: (String -> Either String a) -> ReadM a`+convenience function to help create these values, where a `Left` will+hold the error message for a parse failure.++```haskell+data FluxCapacitor = ...++parseFluxCapacitor :: ReadM FluxCapacitor+parseFluxCapacitor = eitherReader $ \s -> ...++option parseFluxCapacitor ( long "flux-capacitor" )+```++One can also use `ReadM` directly, using `readerAsk` to obtain the+command line string, and `readerAbort` or `readerError` within the+`ReadM` monad to exit with an error message.++One nice property of `eitherReader` is how well it composes with+[attoparsec] parsers with++```haskell+import qualified Data.Attoparsec.Text as A+attoReadM :: A.Parser a -> ReadM a+attoReadM p = eitherReader (A.parseOnly p . T.pack)+```++### Preferences+`PrefsMod`s can be used to customise the look of the usage text and+control when it is displayed; turn off backtracking of subparsers;+and turn on [disambiguation](#disambiguation).++To use these modifications, provide them to the `prefs` builder,+and pass the resulting preferences to one of the parser runners+that take an `ParserPrefs` parameter, like `customExecParser`.+++### Disambiguation++It is possible to configure optparse-applicative to perform automatic+disambiguation of prefixes of long options. For example, given a+program `foo` with options `--filename` and `--filler`, typing++    $ foo --fil test.txt++fails, whereas typing++    $ foo --file test.txt++succeeds, and correctly identifies `"file"` as an unambiguous prefix+of the `filename` option.++Option disambiguation is *off* by default. To enable it, use the+`disambiguate` `PrefsMod` modifier as described above.++Here is a minimal example:++```haskell+import Options.Applicative++sample :: Parser ()+sample = () <$+  switch (long "filename") <*+  switch (long "filler")++main :: IO ()+main = customExecParser p opts+  where+    opts = info (helper <*> sample) idm+    p = prefs disambiguate++```++**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+the usage text, and determine when it should be displayed.++The `progDesc`, `header`, and `footer` functions can be used to+specify a brief description or tagline for the program, and detailed+information surrounding the generated option and command descriptions.++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`+combinator has been applied to the `Parser`.++Authors can also use the preferences `showHelpOnError` or+`showHelpOnEmpty` to show the help text on any parser failure or+when a command is not complete and at the beginning of the parse+of the main program or one of its subcommands respectively.++Even if the help text is not shown for an error, a specific error+message will be, indicating what's missing, or what was unable to+be parsed.++```haskell+myParser :: Parser ()+myParser = ...++main :: IO ()+main = customExecParser p opts+  where+    opts = info (myParser <**> helper) idm+    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+subcommands is command group separation.++```haskell+data Sample+  = Hello [String]+  | Goodbye+  deriving (Eq, Show)++hello :: Parser Sample+hello = Hello <$> many (argument str (metavar "TARGET..."))++sample :: Parser Sample+sample = hsubparser+       ( command "hello" (info hello (progDesc "Print greeting"))+      <> command "goodbye" (info (pure Goodbye) (progDesc "Say goodbye"))+       )+      <|> hsubparser+       ( command "bonjour" (info hello (progDesc "Print greeting"))+      <> command "au-revoir" (info (pure Goodbye) (progDesc "Say goodbye"))+      <> commandGroup "French commands:"+      <> hidden+       )+```++This will logically separate the usage text for the two subparsers+(these would normally appear together if the `commandGroup` modifier+was not used). The `hidden` modifier suppresses the metavariable+for the second subparser being show in the brief usage line, which+is desirable in some cases.++In this example we have essentially created synonyms for our parser,+but one could use this to separate common commands from rare ones,+or safe from dangerous.++The usage text for the preceding example is:+```+Usage: commands COMMAND++Available options:+  -h,--help                Show this help text++Available commands:+  hello                    Print greeting+  goodbye                  Say goodbye++French commands:+  bonjour                  Print greeting+  au-revoir                Say goodbye+```++## Bash, Zsh, and Fish Completions++`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,+   will install the necessary machinery to make bash completion work. For a+   quick test, you can run something like (for a program called `foo` on the+   `PATH`):++   ```console+   $ source <(foo --bash-completion-script `which foo`)+   ```++   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;++ - `--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;++ - `--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+program `foo` has an option with a long name `output`, typing++```console+$ foo --ou<TAB>+```++will complete `--output` automatically.++Arguments (either of regular options, or top-level) are not completed by+default. To enable completion for arguments, use one of the following modifiers+on a regular option or argument:++ - `completeWith`: specifies a list of possible completions to choose from;+ - `action`: specifies a completion "action". An action dynamically determines+   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.++Completion modifiers can be used multiple times: the resulting completions will+call all of them and join the results.++### Internals++When running a parser with `execParser`, the parser is extended with+`bashCompletionParser`, which defines the above options.++When completion is triggered, the completion script calls the executable with+the special `--bash-completion-index` and `--bash-completion-word` options.++The original parser is therefore run in *completion mode*, i.e. `runParser` is+called on a different monad, which keeps track of the current state of the+parser, and exits when all arguments have been processed.++The completion monad returns, on failure, either the last state of the parser+(if no option could be matched), or the completer associated to an option (if+it failed while fetching the argument for that option).++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 (or an appropriate alternative for the other shells).++## Arrow interface++It is also possible to use the [Arrow syntax][arrows] to combine basic parsers.++This can be particularly useful when the structure holding parse results is+deeply nested, or when the order of fields differs from the order in which the+parsers should be applied.++Using functions from the `Options.Applicative.Arrows` module, one can write,+for example:++```haskell+data Options = Options+  { optArgs :: [String]+  , optVerbose :: Bool }++opts :: Parser Options+opts = runA $ proc () -> do+  verbosity  <- asA (option auto (short 'v' <> value 0)) -< ()+  let verbose = verbosity > 0+  args       <- asA (many (argument str idm)) -< ()+  returnA -< Options args verbose+```++where parsers are converted to arrows using `asA`, and the resulting+composed arrow is converted back to a `Parser` with `runA`.++See `tests/Examples/Cabal.hs` for a slightly more elaborate example+using the arrow syntax for defining parsers.++Note that the `Arrow` interface is provided only for convenience. The+API based on `Applicative` is just as expressive, although it might be+cumbersome to use in certain cases.++## Applicative do++Some may find using optparse-applicative easier using do notation.+However, as `Parser` is not an instance of `Monad`, this can only+be done in recent versions of GHC using the *ApplicativeDo* extension.+For example, a parser specified in this manner might be++```haskell+{-# LANGUAGE RecordWildCards            #-}+{-# LANGUAGE ApplicativeDo              #-}++data Options = Options+  { optArgs :: [String]+  , optVerbose :: Bool }++opts :: Parser Options+opts = do+  optVerbose    <- switch (short 'v')+  optArgs       <- many (argument str idm)+  pure Options {..}+```++Here we've also used the *RecordWildCards* extension to make the+parser specification cleaner. Compilation errors referring to `Monad`+instances not being found are likely because the `Parser` specified+can not be implemented entirely with `Applicative` (Note however,+there were a few desugaring bugs regarding ApplicativeDo in GHC+8.0.1, function application with `($)` in particular may not work,+and the `pure` value should instead be wrapped parenthetically).++## FAQ++* Monadic parsing?++  If a Monadic style were to be used, there would be no possible+  way to traverse the parser and generate a usage string, or for+  us to allow for options to be parsed in any order. Therefore it+  is intentionally unsupported to write a `Parser` in this manner+  with optparse-applicative, and the `Parser` type does not have+  an instance for `Monad`.++* Overlapping flags and options / options with optional arguments?++  This is not supported as it can lead to an ambiguous parse.++  For example, if we supported and had an optional value option+  "--foo" and a flag "--bar", is "--foo --bar" the option with value+  "--bar", or the default value with the flag switched on? What if+  instead of a switch we had many positional string arguments, is+  the first string the option's value or the first positional?++  It is suggested to instead use the `Alternative` instance of+  `Parser` and create a flag', an option, and a pure value for the+  default (with different names for the flag and option).++* Backtracking on `ReadM` errors?++  Parser structures are predetermined at parse time. This means+  that if a `ReadM` fails, the whole parse must also fail, we can't+  consider any alternatives, as there can be no guarantee that the+  remaining structure will fit.  One occasionally confusing side+  effect of this is that two positional arguments for different+  constructors of a sum type can't be composed at the parser level;+  rather, this must be done at the `ReadM` level. For example:++  ```haskell+  import Options.Applicative++  data S3orFile = S3 BucketKey | File FilePath++  s3Read, fileRead :: ReadM S3orFile+  s3Read = S3 <$> ...+  fileRead = File <$> ...++  correct :: Parser S3orFile+  correct = argument (s3Read <|> fileRead) idm++  incorrect :: Parser S3orFile+  incorrect = argument s3Read idm <|> argument fileRead idm+  ```++## How it works+An applicative `Parser` is essentially a heterogeneous list or tree+of `Option`s, implemented with existential types.++All options are therefore known statically (i.e. before parsing,+not necessarily before runtime), and can, for example, be traversed+to generate a help text. Indeed, when displaying the usage text for+a parser, we use an intermediate tree structure.++When we examine the user's input, each argument is examined to+determine if it's an option or flag, or a positional argument. The+parse tree is then searched for a matching term, and if it finds+one, that leaf of the tree is replaced with the value itself. When+all input has been processed, we see if we can generate the complete+value, and if not issue an error.++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+ [attoparsec]: http://hackage.haskell.org/package/attoparsec+ [bash documentation]: http://www.gnu.org/software/bash/manual/html_node/Programmable-Completion-Builtins.html+ [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]: 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,116 +1,154 @@ name:                optparse-applicative-version:             0.12.1.0+version:             0.19.0.0 synopsis:            Utilities and combinators for parsing command line options description:-    Here is a simple example of an applicative option parser:-    .-    @-    data Sample = Sample-    &#x20; &#x7b; hello :: String-    &#x20; , quiet :: Bool &#x7d;-    .-    sample :: Parser Sample-    sample = Sample-    &#x20; \<$\> strOption-    &#x20;     ( long \"hello\"-    &#x20;    \<\> metavar \"TARGET\"-    &#x20;    \<\> help \"Target for the greeting\" )-    &#x20; \<*\> switch-    &#x20;     ( long \"quiet\"-    &#x20;    \<\> help \"Whether to be quiet\" )-    @-    .-    The parser is built using 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').-    .-    A parser can be used like this:-    .-    @-    greet :: Sample -> IO ()-    greet (Sample h False) = putStrLn $ \"Hello, \" ++ h-    greet _ = return ()-    .-    main :: IO ()-    main = execParser opts \>\>= greet-    &#x20; where-    &#x20;   opts = info (helper \<*\> sample)-    &#x20;     ( fullDesc-    &#x20;    \<\> progDesc \"Print a greeting for TARGET\"-    &#x20;    \<\> header \"hello - a test for optparse-applicative\" )-    @-    .-    The @greet@ function is the entry point of the program, while @opts@ is a-    complete description of the program, used when generating a help text. The-    'helper' combinator takes any parser, and adds a @help@ option to it (which-    always fails).-    .-    The @hello@ option in this example is mandatory (since it doesn't have a-    default value), so running the program without any argument will display a-    help text:+    optparse-applicative is a haskell library for parsing options+    on the command line, and providing a powerful applicative+    interface for composing them.     .- >hello - a test for optparse-applicative- >- >Usage: hello --hello TARGET [--quiet]- >  Print a greeting for TARGET- >- >Available options:- >  -h,--help                Show this help text- >  --hello TARGET           Target for the greeting- >  --quiet                  Whether to be quiet+    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, zsh, and fish completions.     .-    containing a short usage summary, and a detailed list of options with-    descriptions.+    See the included README for detailed instructions and examples,+    which is also available on github+    <https://github.com/pcapriotti/optparse-applicative>. license:             BSD3 license-file:        LICENSE-author:              Paolo Capriotti-maintainer:          paolo@capriotti.io-copyright:           (c) 2012-2014 Paolo Capriotti <paolo@capriotti.io>-category:            System+author:              Paolo Capriotti, Huw Campbell+maintainer:          huw.campbell@gmail.com+copyright:           (c) 2012-2017 Paolo Capriotti <paolo@capriotti.io>+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                      tests/commands.err.txt                      tests/commands_header.err.txt                      tests/commands_header_full.err.txt+                     tests/dropback.err.txt                      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-  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+  hs-source-dirs:      src   ghc-options:         -Wall-  build-depends:       base == 4.*,-                       transformers >= 0.2 && < 0.6,-                       transformers-compat >= 0.3 && < 0.6,-                       process >= 1.0 && < 1.5,-                       ansi-wl-pprint >= 0.6.6 && < 0.7+  default-language:    Haskell98++  -- 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.5   && < 5+                     , text                            >= 1.2+                     , transformers                    >= 0.5   && < 0.7+                     , prettyprinter                   >= 1.7   && < 1.8+                     , prettyprinter-ansi-terminal     >= 1.1.2 && < 1.2++  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 tests+  type:                exitcode-stdio-1.0++  main-is:             test.hs++  ghc-options:         -Wall -threaded -O2 -funbox-strict-fields++  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.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
@@ -4,8 +4,9 @@ import Options.Applicative import Options.Applicative.Arrows -#if __GLASGOW_HASKELL__ <= 702 import Data.Monoid++#if __GLASGOW_HASKELL__ <= 702 (<>) :: Monoid a => a -> a -> a (<>) = mappend #endif@@ -38,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@@ -59,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@@ -123,5 +120,5 @@  main :: IO () main = do-  r <- execParser pinfo+  r <- customExecParser (prefs helpShowGlobals) pinfo   print r
tests/Examples/Commands.hs view
@@ -2,10 +2,10 @@ module Examples.Commands where  import Data.List+import Data.Monoid import Options.Applicative  #if __GLASGOW_HASKELL__ <= 702-import Data.Monoid (<>) :: Monoid a => a -> a -> a (<>) = mappend #endif@@ -13,7 +13,7 @@ data Sample   = Hello [String]   | Goodbye-  deriving Show+  deriving (Eq, Show)  hello :: Parser Sample hello = Hello <$> many (argument str (metavar "TARGET..."))@@ -26,6 +26,16 @@       <> command "goodbye"          (info (pure Goodbye)                (progDesc "Say goodbye"))+       )+      <|> subparser+       ( command "bonjour"+         (info hello+               (progDesc "Print greeting"))+      <> command "au-revoir"+         (info (pure Goodbye)+               (progDesc "Say goodbye"))+      <> commandGroup "French commands:"+      <> hidden        )  run :: Sample -> IO ()
tests/Examples/Formatting.hs view
@@ -1,7 +1,8 @@ module Examples.Formatting where -import Data.Monoid-import Options.Applicative+import           Data.Monoid+import           Options.Applicative+import           Prelude  opts :: Parser Int opts = option auto $ mconcat
tests/Examples/Hello.hs view
@@ -2,37 +2,41 @@ module Examples.Hello where  import Options.Applicative--#if __GLASGOW_HASKELL__ <= 702-import Data.Monoid-(<>) :: Monoid a => a -> a -> a-(<>) = mappend-#endif+import Data.Semigroup ((<>))+import Control.Monad (replicateM_)  data Sample = Sample-  { hello :: String-  , quiet :: Bool }+  { hello  :: String+  , quiet  :: Bool+  , repeat :: Int }   deriving Show  sample :: Parser Sample sample = Sample-     <$> strOption-         ( long "hello"-        <> metavar "TARGET"-        <> help "Target for the greeting" )-     <*> switch-         ( long "quiet"-        <> help "Whether to be quiet" )--greet :: Sample -> IO ()-greet (Sample h False) = putStrLn $ "Hello, " ++ h-greet _ = return ()+      <$> strOption+          ( long "hello"+         <> metavar "TARGET"+         <> help "Target for the greeting" )+      <*> switch+          ( long "quiet"+         <> short 'q'+         <> help "Whether to be quiet" )+      <*> option auto+          ( long "repeat"+         <> help "Repeats for greeting"+         <> showDefault+         <> value 1+         <> metavar "INT" )  main :: IO ()-main = execParser opts >>= greet+main = greet =<< execParser opts  opts :: ParserInfo Sample opts = info (sample <**> helper)   ( fullDesc- <> progDesc "Print a greeting for TARGET"- <> header "hello - a test for optparse-applicative" )+  <> progDesc "Print a greeting for TARGET"+  <> header "hello - a test for optparse-applicative" )++greet :: Sample -> IO ()+greet (Sample h False n) = replicateM_ n . putStrLn $ "Hello, " ++ h+greet _ = return ()
+ 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/carry.err.txt view
@@ -0,0 +1,3 @@+Missing: -a A++Usage: carry c -a A
tests/commands.err.txt view
@@ -6,3 +6,7 @@ Available commands:   hello                    Print greeting   goodbye                  Say goodbye++French commands:+  bonjour                  Print greeting+  au-revoir                Say goodbye
tests/commands_header.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,5 +1,8 @@-Invalid option `-zzz'+Invalid option `-zello' +Did you mean this?+    hello+ foo  Usage: commands_header_full COMMAND@@ -10,3 +13,7 @@ Available commands:   hello                    Print greeting   goodbye                  Say goodbye++French commands:+  bonjour                  Print greeting+  au-revoir                Say goodbye
+ tests/dropback.err.txt view
@@ -0,0 +1,3 @@+Missing: C++Usage: dropback B C
+ 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,9 +1,11 @@ hello - a test for optparse-applicative -Usage: hello --hello TARGET [--quiet]+Usage: hello --hello TARGET [-q|--quiet] [--repeat INT]+   Print a greeting for TARGET  Available options:   --hello TARGET           Target for the greeting-  --quiet                  Whether to be quiet+  -q,--quiet               Whether to be quiet+  --repeat INT             Repeats for greeting (default: 1)   -h,--help                Show this help text
+ tests/helponempty.err.txt view
@@ -0,0 +1,8 @@+Usage: helponempty B C++Available options:+  -h,--help                Show this help text++Available commands:+  b                        +  c
+ tests/helponemptysub.err.txt view
@@ -0,0 +1,4 @@+Usage: helponemptysub c -a A++Available options:+  -a A                     both commands require this
+ 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
@@ -0,0 +1,1050 @@+{-# LANGUAGE StandaloneDeriving         #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TemplateHaskell            #-}+{-# OPTIONS_GHC -fno-warn-orphans       #-}+module Main where++import qualified Examples.Hello as Hello+import qualified Examples.Commands as Commands+import qualified Examples.Cabal as Cabal+import qualified Examples.Alternatives as Alternatives+import qualified Examples.Formatting as Formatting+import 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)+import           Test.QuickCheck.Property++import           Options.Applicative+import           Options.Applicative.Types+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++run :: ParserInfo a -> [String] -> ParserResult a+run = execParserPure defaultPrefs++assertError :: Show a => ParserResult a+            -> (ParserFailure ParserHelp -> Property) -> Property+assertError x f = case x of+  Success r -> counterexample ("expected failure, got success: " ++ show r) failed+  Failure e -> f e+  CompletionInvoked _ -> counterexample "expected failure, got completion" failed++assertResult :: ParserResult a -> (a -> Property) -> Property+assertResult x f = case x of+  Success r -> f r+  Failure e -> do+    let (msg, _) = renderFailure e "test"+    counterexample ("unexpected parse error\n" ++ msg) failed+  CompletionInvoked _ -> counterexample "expected result, got completion" failed++assertHasLine :: String -> String -> Property+assertHasLine l s = counterexample ("expected line:\n\t" ++ l ++ "\nnot found")+                  $ l `elem` lines s++checkHelpTextWith :: Show a => ExitCode -> ParserPrefs -> String+                  -> ParserInfo a -> [String] -> Property+checkHelpTextWith ecode pprefs name p args = ioProperty $ do+  let result = execParserPure pprefs p args+  expected <- readFile $ "tests/" ++ name ++ ".err.txt"+  return $ assertError result $ \failure ->+    let (msg, code) = renderFailure failure name+    in  (expected === msg ++ "\n") .&&. (ecode === code)++checkHelpText :: Show a => String -> ParserInfo a -> [String] -> Property+checkHelpText = checkHelpTextWith ExitSuccess defaultPrefs++prop_hello :: Property+prop_hello = once $+  checkHelpText "hello" Hello.opts ["--help"]++prop_modes :: Property+prop_modes = once $+  checkHelpText "commands" Commands.opts ["--help"]++prop_cmd_header :: Property+prop_cmd_header = once $+  let i  = info (helper <*> Commands.sample) (header "foo")+      r1 = checkHelpTextWith (ExitFailure 1) defaultPrefs+                    "commands_header" i ["-zello"]+      r2 = checkHelpTextWith (ExitFailure 1) (prefs showHelpOnError)+                    "commands_header_full" i ["-zello"]+  in  (r1 .&&. r2)++prop_cabal_conf :: Property+prop_cabal_conf = once $+  checkHelpTextWith ExitSuccess (prefs helpShowGlobals) "cabal" Cabal.pinfo ["configure", "--help"]++prop_args :: Property+prop_args = once $+  let result = run Commands.opts ["hello", "foo", "bar"]+  in  assertResult result ((===) (Commands.Hello ["foo", "bar"]))++prop_args_opts :: Property+prop_args_opts = once $+  let result = run Commands.opts ["hello", "foo", "--bar"]+  in  assertError result (\_ -> property succeeded)++prop_args_ddash :: Property+prop_args_ddash = once $+  let result = run Commands.opts ["hello", "foo", "--", "--bar", "--", "baz"]+  in  assertResult result ((===) (Commands.Hello ["foo", "--bar", "--", "baz"]))++prop_alts :: Property+prop_alts = once $+  let result = run Alternatives.opts ["-b", "-a", "-b", "-a", "-a", "-b"]+  in  assertResult result $ \xs ->+    let a = Alternatives.A+        b = Alternatives.B+    in  [b, a, b, a, a, b] === xs++prop_show_default :: Property+prop_show_default = once $+  let p = option auto+          ( short 'n'+          <> help "set count"+          <> value (0 :: Int)+          <> showDefault )+      i = info (p <**> helper) idm+      result = run i ["--help"]+  in  assertError result $ \failure ->+    let (msg, _) = renderFailure failure "test"+    in  assertHasLine+        "  -n ARG                   set count (default: 0)"+        msg++prop_alt_cont :: Property+prop_alt_cont = once $+  let p = Alternatives.a <|> Alternatives.b+      i = info p idm+      result = run i ["-a", "-b"]+  in  assertError result (\_ -> property succeeded)++prop_alt_help :: Property+prop_alt_help = once $+  let p :: Parser (Maybe (Either String String))+      p = p1 <|> p2 <|> p3+      p1 = (Just . Left)+        <$> strOption ( long "virtual-machine"+                     <> metavar "VM"+                     <> help "Virtual machine name" )+      p2 = (Just . Right)+        <$> strOption ( long "cloud-service"+                     <> metavar "CS"+                     <> help "Cloud service name" )+      p3 = flag' Nothing ( long "dry-run" )+      i = info (p <**> helper) idm+  in checkHelpText "alt" i ["--help"]++prop_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 :: 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+  in checkHelpTextWith (ExitFailure 1) defaultPrefs "nested" i ["c", "b"]++prop_drops_back_contexts :: Property+prop_drops_back_contexts = once $+  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+      i = info (p0 <**> helper) idm+  in checkHelpTextWith (ExitFailure 1) defaultPrefs "dropback" i ["b", "-aA"]++prop_context_carry :: Property+prop_context_carry = once $+  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+      i = info (p0 <**> helper) idm+  in checkHelpTextWith (ExitFailure 1) defaultPrefs "carry" i ["b", "-aA", "c"]++prop_help_on_empty :: Property+prop_help_on_empty = once $+  let p3 :: 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+      i = info (p0 <**> helper) idm+  in checkHelpTextWith (ExitFailure 1) (prefs showHelpOnEmpty) "helponempty" i []++prop_help_on_empty_sub :: Property+prop_help_on_empty_sub = once $+  let p3 :: 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+      i = info (p0 <**> helper) idm+  in checkHelpTextWith (ExitFailure 1) (prefs showHelpOnEmpty) "helponemptysub" i ["b", "-aA", "c"]++prop_many_args :: Property+prop_many_args = forAll (choose (0,2000)) $ \nargs ->+  let p :: Parser [String]+      p = many (argument str idm)+      i = info p idm+      result = run i (replicate nargs "foo")+  in  assertResult result (\xs -> nargs === length xs)++prop_disambiguate :: Property+prop_disambiguate = once $+  let p =   flag' (1 :: Int) (long "foo")+        <|> flag' 2 (long "bar")+        <|> flag' 3 (long "baz")+      i = info p idm+      result = execParserPure (prefs disambiguate) i ["--f"]+  in  assertResult result ((===) 1)++prop_ambiguous :: Property+prop_ambiguous = once $+  let p =   flag' (1 :: Int) (long "foo")+        <|> flag' 2 (long "bar")+        <|> flag' 3 (long "baz")+      i = info p idm+      result = execParserPure (prefs disambiguate) i ["--ba"]+  in  assertError result (\_ -> property succeeded)+++prop_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 = (,)+        <$> strOption (long "foo" <> value "")+        <*> strOption (long "bar" <> value "")+      i = info p idm+      result = run i ["--bash-completion-index", "0"]+  in case result of+    CompletionInvoked (CompletionResult err) -> do+      completions <- lines <$> err "test"+      return $ ["--foo", "--bar"] === completions+    Failure _   -> return $ counterexample "unexpected failure" failed+    Success val -> return $ counterexample ("unexpected result " ++ show val) failed++prop_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 :: Parser [String]+      p = many (argument str (metavar "ARGS..."))+      i = info (p <**> helper) briefDesc+      result = run i ["--help"]+  in assertError result $ \failure ->+    let text = head . lines . fst $ renderFailure failure "test"+    in  "Usage: test [ARGS...]" === text++prop_issue_19 :: Property+prop_issue_19 = once $+  let p = option (fmap Just str)+        ( short 'x'+       <> value Nothing )+      i = info (p <**> helper) idm+      result = run i ["-x", "foo"]+  in  assertResult result (Just "foo" ===)++prop_arguments1_none :: Property+prop_arguments1_none =+  let p :: 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 :: 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 :: Parser [String]+      p =  switch (short 'x')+        *> many (argument str idm)+      i = info p idm+      result = run i ["--", "-x"]+  in assertResult result $ \args -> ["-x"] === args++prop_issue_35 :: Property+prop_issue_35 = once $+  let p =  flag' True (short 't' <> hidden)+       <|> flag' False (short 'f')+      i = info p idm+      result = run i []+  in assertError result $ \failure ->+    let text = lines . fst $ renderFailure failure "test"+    in  ["Missing: -f", "", "Usage: test -f"] === text++prop_backtracking :: Property+prop_backtracking = once $+  let p2 = switch (short 'a')+      p1 = (,)+        <$> subparser (command "c" (info p2 idm))+        <*> switch (short 'b')+      i = info (p1 <**> helper) idm+      result = execParserPure (prefs noBacktrack) i ["c", "-b"]+  in assertError result $ \_ -> property succeeded++prop_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")+             <*> option auto (long "key")+      i = info p idm+      result = run i ["--port", "foo", "--key", "291"]+  in assertError result $ \failure ->+      let (msg, _) = renderFailure failure "test"+          errMsg   = head $ lines msg+      in  conjoin [ counterexample "no context in error message (option)" ("port" `isInfixOf` errMsg)+                  , counterexample "no context in error message (value)"  ("foo" `isInfixOf` errMsg)]+  where+    pk :: Int -> Int -> (Int, Int)+    pk = (,)++condr :: (Int -> Bool) -> ReadM Int+condr f = do+  x <- auto+  guard (f x)+  return x++prop_arg_order_1 :: Property+prop_arg_order_1 = once $+  let p = (,)+          <$> argument (condr even) idm+          <*> argument (condr odd) idm+      i = info p idm+      result = run i ["3", "6"]+  in assertError result $ \_ -> property succeeded++prop_arg_order_2 :: Property+prop_arg_order_2 = once $+  let p = (,,)+        <$> argument (condr even) idm+        <*> option (condr even) (short 'a')+        <*> option (condr odd) (short 'b')+      i = info p idm+      result = run i ["2", "-b", "3", "-a", "6"]+  in assertResult result ((===) (2, 6, 3))++prop_arg_order_3 :: Property+prop_arg_order_3 = once $+  let p = (,)+          <$> (  argument (condr even) idm+             <|> option auto (short 'n') )+          <*> argument (condr odd) idm+      i = info p idm+      result = run i ["-n", "3", "5"]+  in assertResult result ((===) (3, 5))++prop_unix_style :: Int -> Int -> Property+prop_unix_style j k =+  let p = (,)+          <$> flag' j (short 'x')+          <*> flag' k (short 'c')+      i = info p idm+      result = run i ["-xc"]+  in assertResult result ((===) (j,k))++prop_unix_with_options :: Property+prop_unix_with_options = once $+  let p = (,)+          <$> flag' (1 :: Int) (short 'x')+          <*> strOption (short 'a')+      i = info p idm+      result = run i ["-xac"]+  in assertResult result ((===) (1, "c"))++prop_count_flags :: Property+prop_count_flags = once $+  let p = length <$> many (flag' () (short 't'))+      i = info p idm+      result = run i ["-ttt"]+  in assertResult result ((===) 3)++prop_issue_47 :: Property+prop_issue_47 = once $+  let p = option r (long "test" <> value 9) :: Parser Int+      r = readerError "error message"+      result = run (info p idm) ["--test", "x"]+  in assertError result $ \failure ->+    let text = head . lines . fst $ renderFailure failure "test"+    in  counterexample "no error message" ("error message" `isInfixOf` text)++prop_long_help :: Property+prop_long_help = once $+  let p = Formatting.opts <**> helper+      i = info p+        ( progDesc (concat+            [ "This is a very long program description. "+            , "This text should be automatically wrapped "+            , "to fit the size of the terminal" ]) )+  in checkHelpTextWith ExitSuccess (prefs (columns 50)) "formatting" i ["--help"]++prop_issue_50 :: Property+prop_issue_50 = once $+  let p = argument str (metavar "INPUT")+          <* switch (long "version")+      result = run (info p idm) ["--version", "test"]+  in assertResult result $ \r -> "test" === r++prop_intersperse_1 :: Property+prop_intersperse_1 = once $+  let p = many (argument str (metavar "ARGS"))+          <* switch (short 'x')+      result = run (info p noIntersperse)+                 ["a", "-x", "b"]+  in assertResult result $ \args -> ["a", "-x", "b"] === args++prop_intersperse_2 :: Property+prop_intersperse_2 = once $+  let p = subparser+          (  command "run"+             ( info (many (argument str (metavar "OPTIONS")))+                    noIntersperse )+          <> command "test"+             ( info (many (argument str (metavar "ARGS")))+                    idm ) )+      i = info p idm+      result1 = run i ["run", "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+        ( metavar "FOO"+        <> command "run" (info (pure "foo") idm) )+      i = info p idm+  in assertError (run i []) $ \failure -> do+    let text = lines . fst $ renderFailure failure "test"+    ["Missing: FOO", "", "Usage: test FOO"] === text++prop_multiple_subparsers :: Property+prop_multiple_subparsers = once $+  let p1 = subparser+        (command "add" (info (pure ())+             ( progDesc "Add a file to the repository" )))+      p2 = subparser+        (command "commit" (info (pure ())+             ( progDesc "Record changes to the repository" )))+      i = info (p1 *> p2 <**> helper) idm+  in checkHelpText "subparsers" i ["--help"]++prop_argument_error :: Property+prop_argument_error = once $+  let r = (auto >>= \x -> x <$ guard (x == 42))+        <|> (str >>= \x -> readerError (x ++ " /= 42"))+      p1 = argument r idm :: Parser Int+      i = info (p1 *> p1) idm+  in assertError (run i ["3", "4"]) $ \failure ->+    let text = head . lines . fst $ renderFailure failure "test"+    in  "3 /= 42" === text++prop_reader_error_mplus :: Property+prop_reader_error_mplus = once $+  let r = (auto >>= \x -> x <$ guard (x == 42))+        <|> (str >>= \x -> readerError (x ++ " /= 42"))+      p1 = argument r idm :: Parser Int+      i = info p1 idm+  in assertError (run i ["foo"]) $ \failure ->+    let text = head . lines . fst $ renderFailure failure "test"+    in  "foo /= 42" === text++prop_missing_flags_described :: Property+prop_missing_flags_described = once $+  let p :: Parser (String, String, Maybe String)+      p = (,,)+       <$> option str (short 'a')+       <*> option str (short 'b')+       <*> optional (option str (short 'c'))+      i = info p idm+  in assertError (run i ["-b", "3"]) $ \failure ->+    let text = head . lines . fst $ renderFailure failure "test"+    in  "Missing: -a ARG" === text++prop_many_missing_flags_described :: Property+prop_many_missing_flags_described = once $+  let p :: Parser (String, 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_alt_missing_flags_described :: Property+prop_alt_missing_flags_described = once $+  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 :: Parser [(String, String)]+      p = many $ (,) <$> argument str idm <*> argument str idm+      i = info p idm+      nargs = 10000+      result = run i (replicate nargs "foo")+  in assertResult result $ \xs -> nargs `div` 2 === length xs++prop_many_pairs_failure :: Property+prop_many_pairs_failure = once $+  let p :: Parser [(String, String)]+      p = many $ (,) <$> argument str idm <*> argument str idm+      i = info p idm+      nargs = 9999+      result = run i (replicate nargs "foo")+  in assertError result $ \_ -> property succeeded++prop_many_pairs_lazy_progress :: Property+prop_many_pairs_lazy_progress = once $+  let p :: 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)+++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++prop_listToChunk_2 :: [String] -> Property+prop_listToChunk_2 xs = listToChunk xs === mconcat (fmap pure xs)++prop_extractChunk_1 :: String -> Property+prop_extractChunk_1 x = extractChunk (pure x) === x++prop_extractChunk_2 :: Chunk String -> Property+prop_extractChunk_2 x = extractChunk (fmap pure x) === x++prop_stringChunk_1 :: Positive Double -> Positive Int -> String -> Property+prop_stringChunk_1 (Positive f) (Positive w) s =+  equalDocs f w (extractChunk (stringChunk 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++---++return []+main :: IO ()+main = do+  result <- $(quickCheckAll)+  unless result exitFailure