packages feed

optparse-applicative 0.14.3.0 → 0.15.0.0

raw patch · 38 files changed

+3399/−3134 lines, 38 filesdep ~ansi-wl-pprintdep ~basedep ~bytestring

Dependency ranges changed: ansi-wl-pprint, base, bytestring

Files

CHANGELOG.md view
@@ -1,3 +1,27 @@+## 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 represeted 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.@@ -97,17 +121,17 @@   fires when a command or subcommand is begun, and suppresses the "Missing:"   error text. -- Fix ghc 8.0 warnings+- Fix ghc 8.0 warnings. -- Fix ghc 7.10 warnings+- Fix ghc 7.10 warnings. -- Bump dependency bounds+- Bump dependency bounds. -- Add maybeReader function for convenient ReadM creation+- Add maybeReader function for convenient ReadM creation. -- Move eitherReader to Readers section (for better discoverability)+- Move eitherReader to Readers section (for better discoverability). -- Fix hsubparser metavar override+- Fix hsubparser metavar override.  - Remove ComplError, which was dead code. @@ -123,9 +147,9 @@  - Updated dependency bounds. -- Improve subparser contexts to improve usage error texts+- Improve subparser contexts to improve usage error texts. -- Doc+- Docs.  - Fixed bugs     * \# 164 - Invalid options and invalid arguments after parser has succeeded@@ -145,7 +169,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. @@ -243,7 +267,7 @@  ## Version 0.7.0.1 (18 Oct 2013) -- Minor docs fixes+- Minor docs fixes.  ## Version 0.7.0 (17 Oct 2013) @@ -271,15 +295,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@@ -295,7 +319,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. @@ -311,7 +335,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. @@ -402,20 +426,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,235 +0,0 @@-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,--  -- ** Modifiers-  ---  -- | 'Parser' builders take a modifier, which represents a modification of the-  -- properties of an option, and can be composed as a monoid.-  ---  -- Contraints are often used to ensure that the modifiers can be sensibly applied.-  -- For example, positional arguments can't be specified by long or short names,-  -- so the 'HasName' constraint is used to ensure we have a flag or option.-  Mod,--  short,-  long,-  help,-  helpDoc,-  value,-  showDefaultWith,-  showDefault,-  metavar,-  noArgError,-  hidden,-  internal,-  style,-  command,-  commandGroup,-  completeWith,-  action,-  completer,-  idm,-  mappend,--  OptionFields,-  FlagFields,-  ArgumentFields,-  CommandFields,--  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 'ByteString' and 'Text'; and 'auto', which uses the 'Read'-  -- typeclass, and is good for simple types like 'Int' or 'Double'.-  ---  -- More complex types can use the 'eitherReader' or 'maybeReader'-  -- functions to pattern match or use a more expressive parser like a-  -- member of the 'Parsec' family.-  ReadM,--  auto,-  str,-  maybeReader,-  eitherReader,-  disabled,-  readerAbort,-  readerError,--  -- * Program descriptions-  ---  -- ** 'ParserInfo'-  ---  -- | A 'ParserInfo' describes a command line program, used to generate a help-  -- screen. Two help modes are supported: brief and full. In brief mode, only-  -- an option and argument summary is displayed, while in full mode each-  -- available option and command, including hidden ones, is described.-  ---  -- A 'ParserInfo' should be created with the 'info' function and a set of-  -- 'InfoMod' modifiers.-  ---  info,--  ParserInfo(..),--  InfoMod,-  fullDesc,-  briefDesc,-  header,-  headerDoc,-  footer,-  footerDoc,-  progDesc,-  progDescDoc,-  failureCode,-  noIntersperse,-  forwardOptions,--  -- * Running parsers-  ---  -- | The execParser family of functions are used to run parsers-  execParser,-  customExecParser,-  execParserPure,--  -- ** Handling parser results manually-  getParseResult,-  handleParseResult,-  parserFailure,-  renderFailure,-  overFailure,--  -- ** 'ParserPrefs'-  ---  -- | A 'ParserPrefs' contains general preferences for all command-line-  -- options, and should be built with the 'prefs' function.-  prefs,--  ParserPrefs(..),--  PrefsMod,-  multiSuffix,-  disambiguate,-  showHelpOnError,-  showHelpOnEmpty,-  noBacktrack,-  columns,-  defaultPrefs,--  -- * Completions-  ---  -- | optparse-applicative supplies a rich completion system for bash,-  -- zsh, and fish shells.-  ---  -- 'Completer' functions are used for option and argument to complete-  -- their values.-  ---  -- Use the 'completer' builder to use these.-  -- The 'action' and 'completeWith' builders are also provided for-  -- convenience, to use 'bashCompleter' and 'listCompleter' as a 'Mod'.-  Completer,-  mkCompleter,-  listIOCompleter,--  listCompleter,-  bashCompleter,--  -- * Types-  ParseError(..),-  ParserHelp(..),-  ParserFailure(..),-  ParserResult(..),-  CompletionResult(..)--  ) where---- reexport Applicative here for convenience-import Control.Applicative--import Options.Applicative.Common-import Options.Applicative.Builder-import Options.Applicative.Builder.Completer-import Options.Applicative.Extra-import Options.Applicative.Types--{-# ANN module "HLint: ignore Use import/export shortcut" #-}
− Options/Applicative/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,254 +0,0 @@--- | You don't need to import this module to enable bash completion.------ See--- <http://github.com/pcapriotti/optparse-applicative/wiki/Bash-Completion the wiki>--- for more information on bash completion.-module Options.Applicative.BashCompletion-  ( bashCompletionParser-  ) where--import Control.Applicative-import Prelude-import Data.Foldable ( asum )-import Data.List ( isPrefixOf )-import Data.Maybe ( fromMaybe, listToMaybe )--import Options.Applicative.Builder-import Options.Applicative.Common-import Options.Applicative.Internal-import Options.Applicative.Types-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-    failure opts = CompletionResult-      { execCompletion = \progn -> unlines <$> opts progn }--    complParser = asum-      [ failure <$>-        (  bashCompletionQuery pinfo pprefs-        -- To get rich completions, one just needs the first-        -- command. To customise the lengths, use either of-        -- the `desc-length` options.-        -- zsh commands can go on a single line, so they might-        -- want to be longer.-        <$> ( flag' Enriched (long "bash-completion-enriched" `mappend` internal)-                <*> option auto (long "bash-completion-option-desc-length" `mappend` internal `mappend` value 40)-                <*> option auto (long "bash-completion-command-desc-length" `mappend` internal `mappend` value 40)-          <|> pure Standard-          )-        <*> (many . strOption) (long "bash-completion-word"-                                  `mappend` internal)-        <*> option auto (long "bash-completion-index" `mappend` internal) )-      , failure <$>-          (bashCompletionScript <$>-            strOption (long "bash-completion-script" `mappend` internal))-      , failure <$>-          (fishCompletionScript <$>-            strOption (long "fish-completion-script" `mappend` internal))-      , failure <$>-          (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 hinfo opt = case optMain opt of-      OptReader ns _ _-         | argPolicy /= AllPositionals-        -> return . add_opt_help opt $ show_names ns-         | otherwise-        -> return []-      FlagReader ns _-         | argPolicy /= AllPositionals-        -> return . add_opt_help opt $ show_names ns-         | otherwise-        -> return []-      ArgReader rdr-         | hinfoUnreachableArgs hinfo-        -> return []-         | otherwise-        -> run_completer (crCompleter rdr)-      CmdReader _ ns p-         | hinfoUnreachableArgs hinfo-        -> return []-         | otherwise-        -> return . add_cmd_help p $ filter_names ns--    -- When doing enriched completions, add any help specified-    -- to the completion variables (tab separated).-    add_opt_help :: Functor f => Option a -> f String -> f String-    add_opt_help opt = case richness of-      Standard-        -> id-      Enriched len _-        -> fmap (\o -> let h = unChunk $ optHelp opt-                       in  maybe o (\h' -> o ++ "\t" ++ render_line len h') h)--    -- When doing enriched completions, add the command description-    -- to the completion variables (tab separated).-    add_cmd_help :: Functor f => (String -> Maybe (ParserInfo a)) -> f String -> f String-    add_cmd_help p = case richness of-      Standard-        -> id-      Enriched _ len-        -> fmap (\cmd -> let h = p cmd >>= unChunk . infoProgDesc-                         in  maybe cmd (\h' -> cmd ++ "\t" ++ render_line len h') h)--    show_names :: [OptName] -> [String]-    show_names = filter_names . map showOption--    -- We only want to show a single line in the completion results description.-    -- If there was a line break, it would come across as a different completion-    -- possibility.-    render_line :: Int -> Doc -> String-    render_line len doc = case lines (displayS (renderPretty 1 len doc) "") of-      [] -> ""-      [x] -> x-      x : _ -> x ++ "..."--    filter_names :: [String] -> [String]-    filter_names = filter is_completion--    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--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 ]--{--/Note/: Fish Shell--Derived from Drezil's post in #169.--@-commandline--c or --cut-at-cursor only print selection up until the current cursor position--o or --tokenize tokenize the selection and print one string-type token per line-@--We tokenize so that the call to count (and hence --bash-completion-index)-gets the right number use cut-at-curstor to not bother sending anything-after the cursor position, which allows for completion of the middle of-words.--Tab characters separate items from descriptions.--}-fishCompletionScript :: String -> String -> IO [String]-fishCompletionScript prog progn = return-  [ " function _" ++ progn-  , "    set -l cl (commandline --tokenize --current-process)"-  , "    # Hack around fish issue #3934"-  , "    set -l cn (commandline --tokenize --cut-at-cursor --current-process)"-  , "    set -l cn (count $cn)"-  , "    set -l tmpline --bash-completion-enriched --bash-completion-index $cn"-  , "    for arg in $cl"-  , "      set tmpline $tmpline --bash-completion-word $arg"-  , "    end"-  , "    for opt in (" ++ prog ++ " $tmpline)"-  , "      if test -d $opt"-  , "        echo -E \"$opt/\""-  , "      else"-  , "        echo -E \"$opt\""-  , "      end"-  , "    end"-  , "end"-  , ""-  , "complete --no-files --command " ++ progn ++ " --arguments '(_"  ++ progn ++  ")'"-  ]--zshCompletionScript :: String -> String -> IO [String]-zshCompletionScript prog progn = return-  [ "#compdef " ++ progn-  , ""-  , "local request"-  , "local completions"-  , "local word"-  , "local index=$((CURRENT - 1))"-  , ""-  , "request=(--bash-completion-enriched --bash-completion-index $index)"-  , "for arg in ${words[@]}; do"-  , "  request=(${request[@]} --bash-completion-word $arg)"-  , "done"-  , ""-  , "IFS=$'\\n' completions=($( " ++ prog ++ " \"${request[@]}\" ))"-  , ""-  , "for word in $completions; do"-  , "  local -a parts"-  , ""-  , "  # Split the line at a tab if there is one."-  , "  IFS=$'\\t' parts=($( echo $word ))"-  , ""-  , "  if [[ -n $parts[2] ]]; then"-  , "     if [[ $word[1] == \"-\" ]]; then"-  , "       local desc=(\"$parts[1] ($parts[2])\")"-  , "       compadd -d desc -- $parts[1]"-  , "     else"-  , "       local desc=($(print -f  \"%-019s -- %s\" $parts[1] $parts[2]))"-  , "       compadd -l -d desc -- $parts[1]"-  , "     fi"-  , "  else"-  , "    compadd -f -- $word"-  , "  fi"-  , "done"-  ]
− Options/Applicative/Builder.hs 
@@ -1,514 +0,0 @@-module Options.Applicative.Builder (-  -- * Parser builders-  ---  -- | This module contains utility functions and combinators to create parsers-  -- for individual options.-  ---  -- Each parser builder takes an option modifier. A modifier can be created by-  -- composing the basic modifiers provided by this module using the 'Monoid'-  -- operations 'mempty' and 'mappend', or their aliases 'idm' and '<>'.-  ---  -- For example:-  ---  -- > out = strOption-  -- >     ( long "output"-  -- >    <> short 'o'-  -- >    <> metavar "FILENAME" )-  ---  -- creates a parser for an option called \"output\".-  subparser,-  strArgument,-  argument,-  flag,-  flag',-  switch,-  abortOption,-  infoOption,-  strOption,-  option,-  nullOption,--  -- * Modifiers-  short,-  long,-  help,-  helpDoc,-  value,-  showDefaultWith,-  showDefault,-  metavar,-  noArgError,-  ParseError(..),-  hidden,-  internal,-  style,-  command,-  commandGroup,-  completeWith,-  action,-  completer,-  idm,-  mappend,--  -- * Readers-  ---  -- | A collection of basic 'Option' readers.-  auto,-  str,-  maybeReader,-  eitherReader,-  disabled,-  readerAbort,-  readerError,--  -- * Builder for 'ParserInfo'-  InfoMod,-  fullDesc,-  briefDesc,-  header,-  headerDoc,-  footer,-  footerDoc,-  progDesc,-  progDescDoc,-  failureCode,-  noIntersperse,-  forwardOptions,-  info,--  -- * Builder for 'ParserPrefs'-  PrefsMod,-  multiSuffix,-  disambiguate,-  showHelpOnError,-  showHelpOnEmpty,-  noBacktrack,-  columns,-  prefs,-  defaultPrefs,--  -- * Types-  Mod,-  ReadM,-  OptionFields,-  FlagFields,-  ArgumentFields,-  CommandFields,--  HasName,-  HasCompleter,-  HasValue,-  HasMetavar-  ) where--import Control.Applicative-import Data.Semigroup hiding (option)-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---- 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 'Text.PrettyPrint.ANSI.Leijen.Doc'--- value.-helpDoc :: Maybe Doc -> Mod f a-helpDoc doc = optionMod $ \p -> p { propHelp = Chunk doc }---- | Specify the error to display when no argument is provided to this option.-noArgError :: ParseError -> Mod OptionFields a-noArgError e = fieldMod $ \p -> p { optNoArgError = 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.-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 bold)------ /NOTE/: This builder is more flexible than its name and example--- allude. One of the motivating examples for its addition was to--- used `const` to completely replace the usage text of an option.-style :: ( Doc -> Doc ) -> Mod f a-style x = optionMod $ \p ->-  p { propDescMod = Just x }---- | Add a command to a subparser option.------ Suggested usage for multiple commands is to add them to a single subparser. e.g.------ @--- sample :: Parser Sample--- sample = subparser---        ( command "hello"---          (info hello (progDesc "Print greeting"))---       <> command "goodbye"---          (info goodbye (progDesc "Say goodbye"))---        )--- @-command :: String -> ParserInfo a -> Mod CommandFields a-command cmd pinfo = fieldMod $ \p ->-  p { cmdCommands = (cmd, pinfo) : cmdCommands p }---- | Add a description to a group of commands.------ Advanced feature for separating logical groups of commands on the parse line.------ If using the same `metavar` for each group of commands, it may yield a more--- attractive usage text combined with `hidden` for some groups.-commandGroup :: String -> Mod CommandFields a-commandGroup g = fieldMod $ \p ->-  p { cmdGroup = Just g }---- | Add a list of possible completion values.-completeWith :: HasCompleter f => [String] -> Mod f a-completeWith = 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.-subparser :: Mod CommandFields a -> Parser a-subparser m = mkParser d g rdr-  where-    Mod _ d g = metavar "COMMAND" `mappend` m-    (groupName, cmds, subs) = mkCommand m-    rdr = CmdReader groupName cmds subs---- | Builder for an argument parser.-argument :: ReadM a -> Mod ArgumentFields a -> Parser a-argument p (Mod f d g) = mkParser d g (ArgReader rdr)-  where-    ArgumentFields compl = f (ArgumentFields mempty)-    rdr = CReader compl p---- | Builder for a 'String' argument.-strArgument :: 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---- | Same as 'option'.-{-# DEPRECATED nullOption "Use 'option' instead" #-}-nullOption :: ReadM a -> Mod OptionFields a -> Parser a-nullOption = option---- | Builder for an option using the given reader.------ This is a regular option, and should always have either a @long@ or--- @short@ name specified in the modifiers (or both).------ > nameParser = option str ( long "name" <> short 'n' )----option :: ReadM a -> Mod OptionFields a -> Parser a-option r m = mkParser d g rdr-  where-    Mod f d g = metavar "ARG" `mappend` m-    fields = f (OptionFields [] mempty ExpectsArgError)-    crdr = CReader (optCompleter fields) r-    rdr = OptReader (optNames fields) crdr (optNoArgError fields)---- | Modifier for 'ParserInfo'.-newtype InfoMod a = InfoMod-  { applyInfoMod :: ParserInfo a -> ParserInfo a }--instance Monoid (InfoMod a) where-  mempty = InfoMod id-  mappend = (<>)--instance Semigroup (InfoMod a) where-  m1 <> m2 = InfoMod $ applyInfoMod m2 . applyInfoMod m1---- | Show a full description in the help text of this parser.-fullDesc :: InfoMod a-fullDesc = InfoMod $ \i -> i { infoFullDesc = True }---- | Only show a brief description in the help text of this parser.-briefDesc :: InfoMod a-briefDesc = InfoMod $ \i -> i { infoFullDesc = False }---- | Specify a header for this parser.-header :: String -> InfoMod a-header s = InfoMod $ \i -> i { infoHeader = paragraph s }---- | Specify a header for this parser as a 'Text.PrettyPrint.ANSI.Leijen.Doc'--- value.-headerDoc :: Maybe Doc -> InfoMod a-headerDoc doc = InfoMod $ \i -> i { infoHeader = Chunk doc }---- | Specify a footer for this parser.-footer :: String -> InfoMod a-footer s = InfoMod $ \i -> i { infoFooter = paragraph s }---- | Specify a footer for this parser as a 'Text.PrettyPrint.ANSI.Leijen.Doc'--- value.-footerDoc :: Maybe Doc -> InfoMod a-footerDoc doc = InfoMod $ \i -> i { infoFooter = Chunk doc }---- | Specify a short program description.-progDesc :: String -> InfoMod a-progDesc s = InfoMod $ \i -> i { infoProgDesc = paragraph s }---- | Specify a short program description as a 'Text.PrettyPrint.ANSI.Leijen.Doc'--- value.-progDescDoc :: Maybe Doc -> InfoMod a-progDescDoc doc = InfoMod $ \i -> i { infoProgDesc = Chunk doc }---- | Specify an exit code if a parse error occurs.-failureCode :: Int -> InfoMod a-failureCode n = InfoMod $ \i -> i { infoFailureCode = n }---- | Disable parsing of regular options after arguments. 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 }---- | 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 = False }---- | Set the maximum width of the generated help text.-columns :: Int -> PrefsMod-columns cols = PrefsMod $ \p -> p { prefColumns = cols }---- | Create a `ParserPrefs` given a modifier-prefs :: PrefsMod -> ParserPrefs-prefs m = applyPrefsMod m base-  where-    base = ParserPrefs-      { prefMultiSuffix = ""-      , prefDisambiguate = False-      , prefShowHelpOnError = False-      , prefShowHelpOnEmpty = False-      , prefBacktrack = True-      , prefColumns = 80 }---- Convenience shortcuts---- | Trivial option modifier.-idm :: Monoid m => m-idm = mempty---- | Default preferences.-defaultPrefs :: ParserPrefs-defaultPrefs = prefs idm
− Options/Applicative/Builder/Completer.hs 
@@ -1,122 +0,0 @@-module Options.Applicative.Builder.Completer-  ( Completer-  , mkCompleter-  , listIOCompleter-  , listCompleter-  , bashCompleter-  ) where--import Control.Applicative-import Prelude-import Control.Exception (IOException, try)-import Data.List (isPrefixOf)-import System.Process (readProcess)--import Options.Applicative.Types---- | Create a 'Completer' from an IO action-listIOCompleter :: IO [String] -> Completer-listIOCompleter ss = Completer $ \s ->-  filter (isPrefixOf s) <$> ss---- | Create a 'Completer' from a constant--- list of strings.-listCompleter :: [String] -> Completer-listCompleter = listIOCompleter . pure---- | Run a compgen completion action.------ Common actions include @file@ and--- @directory@. See--- <http://www.gnu.org/software/bash/manual/html_node/Programmable-Completion-Builtins.html#Programmable-Completion-Builtins>--- for a complete list.-bashCompleter :: String -> Completer-bashCompleter action = Completer $ \word -> do-  let cmd = unwords ["compgen", "-A", action, "--", requote word]-  result <- tryIO $ readProcess "bash" ["-c", cmd] ""-  return . lines . either (const []) id $ result--tryIO :: IO a -> IO (Either IOException a)-tryIO = try---- | Strongly quote the string we pass to compgen.------ We need to do this so bash doesn't expand out any ~ or other--- chars we want to complete on, or emit an end of line error--- when seeking the close to the quote.-requote :: String -> String-requote s =-  let-    -- Bash doesn't appear to allow "mixed" escaping-    -- in bash completions. So we don't have to really-    -- worry about people swapping between strong and-    -- weak quotes.-    unescaped =-      case s of-        -- It's already strongly quoted, so we-        -- can use it mostly as is, but we must-        -- ensure it's closed off at the end and-        -- there's no single quotes in the-        -- middle which might confuse bash.-        ('\'': rs) -> unescapeN rs--        -- We're weakly quoted.-        ('"': rs)  -> unescapeD rs--        -- We're not quoted at all.-        -- We need to unescape some characters like-        -- spaces and quotation marks.-        elsewise   -> unescapeU elsewise-  in-    strong unescaped--  where-    strong ss = '\'' : foldr go "'" ss-      where-        -- If there's a single quote inside the-        -- command: exit from the strong quote and-        -- emit it the quote escaped, then resume.-        go '\'' t = "'\\''" ++ t-        go h t    = h : t--    -- Unescape a strongly quoted string-    -- We have two recursive functions, as we-    -- can enter and exit the strong escaping.-    unescapeN = goX-      where-        goX ('\'' : xs) = goN xs-        goX (x : xs) = x : goX xs-        goX [] = []--        goN ('\\' : '\'' : xs) = '\'' : goN xs-        goN ('\'' : xs) = goX xs-        goN (x : xs) = x : goN xs-        goN [] = []--    -- Unescape an unquoted string-    unescapeU = goX-      where-        goX [] = []-        goX ('\\' : x : xs) = x : goX xs-        goX (x : xs) = x : goX xs--    -- Unescape a weakly quoted string-    unescapeD = goX-      where-        -- Reached an escape character-        goX ('\\' : x : xs)-          -- If it's true escapable, strip the-          -- slashes, as we're going to strong-          -- escape instead.-          | x `elem` "$`\"\\\n" = x : goX xs-          | otherwise = '\\' : x : goX xs-        -- We've ended quoted section, so we-        -- don't recurse on goX, it's done.-        goX ('"' : xs)-          = xs-        -- Not done, but not a special character-        -- just continue the fold.-        goX (x : xs)-          = x : goX xs-        goX []-          = []
− Options/Applicative/Builder/Internal.hs 
@@ -1,183 +0,0 @@-module Options.Applicative.Builder.Internal (-  -- * Internals-  Mod(..),-  HasName(..),-  HasCompleter(..),-  HasValue(..),-  HasMetavar(..),-  OptionFields(..),-  FlagFields(..),-  CommandFields(..),-  ArgumentFields(..),-  DefaultProp(..),--  optionMod,-  fieldMod,--  baseProps,-  mkCommand,-  mkParser,-  mkOption,-  mkProps,--  internal-  ) where--import Control.Applicative-import Control.Monad (mplus)-import Data.Semigroup hiding (Option)-import Prelude--import Options.Applicative.Common-import Options.Applicative.Types--data OptionFields a = OptionFields-  { optNames :: [OptName]-  , optCompleter :: Completer-  , optNoArgError :: 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 'strOption' or 'flag') to--- create options (see 'Options.Applicative.Builder').-data Mod f a = Mod (f a -> f a)-                   (DefaultProp a)-                   (OptProperties -> OptProperties)--optionMod :: (OptProperties -> OptProperties) -> Mod f a-optionMod = Mod id mempty--fieldMod :: (f a -> f a) -> Mod f a-fieldMod f = Mod f mempty id--instance Monoid (Mod f a) where-  mempty = Mod id mempty id-  mappend = (<>)---- | @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-  }--mkCommand :: Mod CommandFields a -> (Maybe String, [String], String -> Maybe (ParserInfo a))-mkCommand m = (group, map fst cmds, (`lookup` cmds))-  where-    Mod f _ _ = m-    CommandFields cmds group = f (CommandFields [] Nothing)--mkParser :: DefaultProp a-         -> (OptProperties -> OptProperties)-         -> OptReader a-         -> Parser a-mkParser d@(DefaultProp def _) g rdr = liftOpt opt <|> maybe empty pure def-  where-    opt = mkOption d g rdr--mkOption :: DefaultProp a-         -> (OptProperties -> OptProperties)-         -> OptReader a-         -> Option a-mkOption d g rdr = Option rdr (mkProps d g)--mkProps :: DefaultProp a-        -> (OptProperties -> OptProperties)-        -> OptProperties-mkProps (DefaultProp def sdef) g = props-  where-    props = (g baseProps)-      { propShowDefault = sdef <*> def }---- | Hide this option from the help text-internal :: Mod f a-internal = optionMod $ \p -> p { propVisibility = Internal }
− Options/Applicative/Common.hs 
@@ -1,311 +0,0 @@-{-# LANGUAGE Rank2Types #-}-module Options.Applicative.Common (-  -- * Option parsers-  ---  -- | A 'Parser' is composed of a list of options. Several kinds of options-  -- are supported:-  ---  --  * Flags: simple no-argument options. When a flag is encountered on the-  --  command line, its value is returned.-  ---  --  * Options: options with an argument. An option can define a /reader/,-  --  which converts its argument from String to the desired value, or throws a-  --  parse error if the argument does not validate correctly.-  ---  --  * Arguments: positional arguments, validated in the same way as option-  --  arguments.-  ---  --  * Commands. A command defines a completely independent sub-parser. When a-  --  command is encountered, the whole command line is passed to the-  --  corresponding parser.-  ---  Parser,-  liftOpt,-  showOption,--  -- * Program descriptions-  ---  -- A 'ParserInfo' describes a command line program, used to generate a help-  -- screen. Two help modes are supported: brief and full. In brief mode, only-  -- an option and argument summary is displayed, while in full mode each-  -- available option and command, including hidden ones, is described.-  ---  -- A basic 'ParserInfo' with default values for fields can be created using-  -- the 'info' function.-  ---  -- A 'ParserPrefs' contains general preferences for all command-line-  -- options, and can be built with the 'prefs' function.-  ParserInfo(..),-  ParserPrefs(..),--  -- * Running parsers-  runParserInfo,-  runParserFully,-  runParser,-  evalParser,--  -- * Low-level utilities-  mapParser,-  treeMapParser,-  optionNames-  ) where--import Control.Applicative-import Control.Monad (guard, mzero, msum, when, liftM)-import Control.Monad.Trans.Class (lift)-import Control.Monad.Trans.State (StateT(..), get, put, runStateT)-import Data.List (isPrefixOf)-import Data.Maybe (maybeToList, isJust, 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--argMatches :: MonadP m => OptReader a -> String-           -> Maybe (StateT Args m a)-argMatches opt arg = case opt of-  ArgReader rdr -> Just . lift $-    runReadM (crReader rdr) arg-  CmdReader _ _ f ->-    flip fmap (f arg) $ \subp -> StateT $ \args -> do-      prefs <- getPrefs-      let runSubparser-            | prefBacktrack prefs = \i a ->-                runParser (infoPolicy i) CmdStart (infoParser i) a-            | otherwise = \i a-            -> (,) <$> runParserInfo i a <*> pure []-      enterContext arg subp *> runSubparser subp args <* exitContext-  _ -> Nothing--optMatches :: MonadP m => Bool -> OptReader a -> OptWord -> Maybe (StateT Args m a)-optMatches disambiguate opt (OptWord arg1 val) = case opt of-  OptReader names rdr no_arg_err -> do-    guard $ has_name arg1 names-    Just $ do-      args <- get-      let mb_args = uncons $ maybeToList val ++ args-      let missing_arg = missingArgP (no_arg_err $ showOption arg1) (crCompleter rdr)-      (arg', args') <- maybe (lift missing_arg) return mb_args-      put args'-      lift $ runReadM (withReadM (errorFor arg1) (crReader rdr)) arg'--  FlagReader names x -> do-    guard $ has_name arg1 names-    -- #242 Flags/switches succeed incorrectly when given an argument.-    -- We'll not match a long option for a flag if there's a word attached.-    -- This was revealing an implementation detail as-    -- `--foo=val` was being parsed as `--foo -val`, which is gibberish.-    guard $ is_short arg1 || isNothing val-    Just $ do-      args <- get-      let val' = (\s -> '-' : s) <$> val-      put $ maybeToList val' ++ args-      return x-  _ -> Nothing-  where-    errorFor name msg = "option " ++ showOption name ++ ": " ++ msg--    is_short (OptShort _) = True-    is_short (OptLong _)  = False--    has_name a-      | disambiguate = any (isOptionPrefix a)-      | otherwise = elem a--isArg :: OptReader a -> Bool-isArg (ArgReader _) = True-isArg _ = False--data OptWord = OptWord OptName (Maybe String)--parseWord :: String -> Maybe OptWord-parseWord ('-' : '-' : w) = Just $ let-  (opt, arg) = case span (/= '=') w of-    (_, "") -> (w, Nothing)-    (w', _ : rest) -> (w', Just rest)-  in OptWord (OptLong opt) arg-parseWord ('-' : w) = case w of-  [] -> Nothing-  (a : rest) -> Just $ let-    arg = rest <$ guard (not (null rest))-    in OptWord (OptShort a) arg-parseWord _ = Nothing--searchParser :: Monad m-             => (forall r . Option r -> NondetT m r)-             -> Parser a -> NondetT m (Parser a)-searchParser _ (NilP _) = mzero-searchParser f (OptP opt) = liftM pure (f opt)-searchParser f (MultP p1 p2) = foldr1 (<!>)-  [ do p1' <- searchParser f p1-       return (p1' <*> p2)-  , do p2' <- searchParser f p2-       return (p1 <*> p2') ]-searchParser f (AltP p1 p2) = msum-  [ searchParser f p1-  , searchParser f p2 ]-searchParser f (BindP p k) = msum-  [ do p' <- searchParser f p-       return $ BindP p' k-  , case evalParser p of-      Nothing -> mzero-      Just aa -> searchParser f (k aa) ]--searchOpt :: MonadP m => ParserPrefs -> OptWord -> Parser a-          -> NondetT (StateT Args m) (Parser a)-searchOpt pprefs w = searchParser $ \opt -> do-  let disambiguate = prefDisambiguate pprefs-                  && optVisibility opt > Internal-  case optMatches disambiguate (optMain opt) w of-    Just matcher -> lift matcher-    Nothing -> mzero--searchArg :: MonadP m => String -> Parser a-          -> NondetT (StateT Args m) (Parser a)-searchArg arg = searchParser $ \opt -> do-  when (isArg (optMain opt)) cut-  case argMatches (optMain opt) arg of-    Just matcher -> lift matcher-    Nothing -> mzero--stepParser :: MonadP m => ParserPrefs -> ArgPolicy -> String-           -> Parser a -> NondetT (StateT Args m) (Parser a)-stepParser _ AllPositionals arg p =-  searchArg arg p-stepParser pprefs ForwardOptions arg p = case parseWord arg of-  Just w -> searchOpt pprefs w p <|> searchArg arg p-  Nothing -> searchArg arg p-stepParser pprefs _ arg p = case parseWord arg of-  Just w -> searchOpt pprefs w p-  Nothing -> searchArg arg p----- | 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-    prefs <- getPrefs-    (mp', args') <- do_step prefs 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 prefs arg argt = (`runStateT` argt)-                           . disamb (not (prefDisambiguate prefs))-                           $ stepParser prefs policy arg p--    newPolicy a = case policy of-      NoIntersperse -> if isJust (parseWord a) then NoIntersperse else AllPositionals-      x             -> x--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. 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 False g-  where-    has_default :: Parser a -> Bool-    has_default p = isJust (evalParser p)--    go :: Bool -> Bool -> Bool-       -> (forall x . OptHelpInfo -> Option x -> b)-       -> Parser a-       -> OptTree b-    go _ _ _ _ (NilP _) = MultNode []-    go m d r f (OptP opt)-      | optVisibility opt > Internal-      = Leaf (f (OptHelpInfo m d r) opt)-      | otherwise-      = MultNode []-    go m d r f (MultP p1 p2) = MultNode [go m d r f p1, go m d r' f p2]-      where r' = r || hasArg p1-    go m d r f (AltP p1 p2) = AltNode [go m d' r f p1, go m d' r f p2]-      where d' = d || has_default p1 || has_default p2-    go _ d r f (BindP p k) =-      let go' = go True d r f p-      in case evalParser p of-        Nothing -> go'-        Just aa -> MultNode [ go', go True d r f (k aa) ]--    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 xs) =-  case concatMap (remove_alt . simplify) xs of-    []  -> MultNode []-    [x] -> x-    xs' -> AltNode xs'-  where-    remove_alt (AltNode ts) = ts-    remove_alt (MultNode []) = []-    remove_alt t = [t]
− Options/Applicative/Extra.hs 
@@ -1,290 +0,0 @@-{-# LANGUAGE RankNTypes #-}-module Options.Applicative.Extra (-  -- * Extra parser utilities-  ---  -- | This module contains high-level functions to run parsers.-  helper,-  hsubparser,-  execParser,-  execParserMaybe,-  customExecParser,-  customExecParserMaybe,-  execParserPure,-  getParseResult,-  handleParseResult,-  parserFailure,-  renderFailure,-  ParserFailure(..),-  overFailure,-  ParserResult(..),-  ParserPrefs(..),-  CompletionResult(..),-  ) where--import Control.Applicative-import Data.Monoid-import Prelude-import System.Environment (getArgs, getProgName)-import System.Exit (exitSuccess, exitWith, ExitCode(..))-import System.IO (hPutStrLn, stderr)--import Options.Applicative.BashCompletion-import Options.Applicative.Builder-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 = abortOption ShowHelpText $ mconcat-  [ long "help"-  , short 'h'-  , help "Show this help text"-  , hidden ]---- | Builder for a command parser with a \"helper\" option attached.--- Used in the same way as `subparser`, but includes a \"--help|-h\" inside--- the subcommand.-hsubparser :: Mod CommandFields a -> Parser a-hsubparser m = mkParser d g rdr-  where-    Mod _ d g = metavar "COMMAND" `mappend` m-    (groupName, cmds, subs) = mkCommand m-    rdr = CmdReader groupName cmds (fmap add_helper . subs)-    add_helper pinfo = pinfo-      { infoParser = infoParser pinfo <**> helper }---- | Run a program description.------ Parse command line arguments. Display help text and exit if any parse error--- occurs.-execParser :: ParserInfo a -> IO a-execParser = customExecParser defaultPrefs---- | Run a program description with custom preferences.-customExecParser :: ParserPrefs -> ParserInfo a -> IO a-customExecParser pprefs pinfo-  = execParserPure pprefs pinfo <$> getArgs-  >>= handleParseResult---- | Handle `ParserResult`.-handleParseResult :: ParserResult a -> IO a-handleParseResult (Success a) = return a-handleParseResult (Failure failure) = do-      progn <- getProgName-      let (msg, exit) = renderFailure failure progn-      case exit of-        ExitSuccess -> putStrLn msg-        _           -> hPutStrLn stderr msg-      exitWith exit-handleParseResult (CompletionInvoked compl) = do-      progn <- getProgName-      msg <- execCompletion compl progn-      putStr msg-      exitSuccess---- | Extract the actual result from a `ParserResult` value.------ This function returns 'Nothing' in case of errors.  Possible error messages--- or completion actions are simply discarded.------ If you want to display error messages and invoke completion actions--- appropriately, use 'handleParseResult' instead.-getParseResult :: ParserResult a -> Maybe a-getParseResult (Success a) = Just a-getParseResult _ = Nothing---- | Run a program description in pure code.------ This function behaves like 'execParser', but can be called from pure code.--- Note that, in case of errors, no message is displayed, and this function--- simply returns 'Nothing'.------ If you need to keep track of error messages, use 'execParserPure' instead.-{-# DEPRECATED execParserMaybe "Use execParserPure together with getParseResult instead" #-}-execParserMaybe :: ParserInfo a -> [String] -> Maybe a-execParserMaybe = customExecParserMaybe defaultPrefs---- | Run a program description with custom preferences in pure code.------ See 'execParserMaybe' for details.-{-# DEPRECATED customExecParserMaybe "Use execParserPure together with getParseResult instead" #-}-customExecParserMaybe :: ParserPrefs -> ParserInfo a -> [String] -> Maybe a-customExecParserMaybe pprefs pinfo args = getParseResult $ execParserPure pprefs pinfo args---- | The most general way to run a program description in pure code.-execParserPure :: ParserPrefs       -- ^ Global preferences for this parser-               -> ParserInfo a      -- ^ Description of the program to run-               -> [String]          -- ^ Program arguments-               -> ParserResult a-execParserPure pprefs pinfo args =-  case runP p pprefs of-    (Right (Right r), _) -> Success r-    (Right (Left c), _) -> CompletionInvoked c-    (Left err, ctx) -> Failure $ parserFailure pprefs pinfo err ctx-  where-    pinfo' = pinfo-      { infoParser = (Left <$> bashCompletionParser pinfo pprefs)-                 <|> (Right <$> infoParser pinfo) }-    p = runParserInfo pinfo' args---- | Generate a `ParserFailure` from a `ParseError` in a given `Context`.------ This function can be used, for example, to show the help text for a parser:------ @handleParseResult . Failure $ parserFailure pprefs pinfo ShowHelpText mempty@-parserFailure :: ParserPrefs -> ParserInfo a-              -> ParseError -> [Context]-              -> ParserFailure ParserHelp-parserFailure pprefs pinfo msg ctx = ParserFailure $ \progn ->-  let h = with_context ctx pinfo $ \names pinfo' -> mconcat-            [ base_help pinfo'-            , usage_help progn names pinfo'-            , suggestion_help-            , error_help ]-  in (h, exit_code, prefColumns pprefs)-  where-    exit_code = case msg of-      ErrorMsg {}        -> ExitFailure (infoFailureCode pinfo)-      UnknownError       -> ExitFailure (infoFailureCode pinfo)-      MissingError {}    -> ExitFailure (infoFailureCode pinfo)-      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--    usage_help progn names i = case msg of-      InfoMsg _-        -> mempty-      _-        -> usageHelp $ vcatChunks-          [ pure . parserUsage pprefs (infoParser i) . unwords $ progn : names-          , fmap (indent 2) . infoProgDesc $ i ]--    error_help = errorHelp $ case msg of-      ShowHelpText-        -> mempty--      ErrorMsg m-        -> stringChunk m--      InfoMsg  m-        -> stringChunk m--      MissingError CmdStart _-        | prefShowHelpOnEmpty pprefs-        -> mempty--      MissingError _ (SomeParser x)-        -> stringChunk "Missing:" <<+>> missingDesc pprefs x--      ExpectsArgError x-        -> stringChunk $ "The option `" ++ x ++ "` expects an argument."--      UnexpectedError arg _-        -> stringChunk msg'-          where-            ---            -- This gives us the same error we have always-            -- reported-            msg' = case arg of-              ('-':_) -> "Invalid option `" ++ arg ++ "'"-              _       -> "Invalid argument `" ++ arg ++ "'"--      UnknownError-        -> mempty---    suggestion_help = suggestionsHelp $ case msg of-      UnexpectedError arg (SomeParser x)-        ---        -- We have an unexpected argument and the parser which-        -- it's running over.-        ---        -- We can make a good help suggestion here if we do-        -- a levenstein distance between all possible suggestions-        -- and the supplied option or argument.-        -> suggestions-          where-            ---            -- Not using chunked here, as we don't want to-            -- show "Did you mean" if there's nothing there-            -- to show-            suggestions = (.$.) <$> prose-                                <*> (indent 4 <$> (vcatChunks . fmap stringChunk $ good ))--            ---            -- We won't worry about the 0 case, it won't be-            -- shown anyway.-            prose       = if length good < 2-                            then stringChunk "Did you mean this?"-                            else stringChunk "Did you mean one of these?"-            ---            -- Suggestions we will show, they're close enough-            -- to what the user wrote-            good        = filter isClose possibles--            ---            -- Bit of an arbitrary decision here.-            -- Edit distances of 1 or 2 will give hints-            isClose a   = editDistance a arg < 3--            ---            -- Similar to how bash completion works.-            -- We map over the parser and get the names-            -- ( no IO here though, unlike for completers )-            possibles   = concat $ mapParser opt_completions x--            ---            -- Look at the option and give back the possible-            -- things the user could type. If it's a command-            -- reader also ensure that it can be immediately-            -- reachable from where the error was given.-            opt_completions hinfo opt = case optMain opt of-              OptReader ns _ _ -> fmap showOption ns-              FlagReader ns _  -> fmap showOption ns-              ArgReader _      -> []-              CmdReader _ ns _  | hinfoUnreachableArgs hinfo-                               -> []-                                | otherwise-                               -> ns-      _-        -> mempty--    base_help :: ParserInfo a -> ParserHelp-    base_help i-      | show_full_help-      = mconcat [h, f, parserHelp pprefs (infoParser i)]-      | otherwise-      = mempty-      where-        h = headerHelp (infoHeader i)-        f = footerHelp (infoFooter i)--    show_full_help = case msg of-      ShowHelpText             -> True-      MissingError CmdStart  _  | prefShowHelpOnEmpty pprefs-                               -> True-      _                        -> prefShowHelpOnError pprefs--renderFailure :: ParserFailure ParserHelp -> String -> (String, ExitCode)-renderFailure failure progn =-  let (h, exit, cols) = execFailure failure progn-  in (renderHelp cols h, exit)
− Options/Applicative/Help.hs 
@@ -1,28 +0,0 @@-module Options.Applicative.Help (-  -- | This is an empty module which re-exports-  --   the help text system for optparse.--  -- | Pretty printer. Reexports most combinators-  --   from Text.PrettyPrint.ANSI.Leijen-  module Options.Applicative.Help.Pretty,--  -- | A free monoid over Doc with helpers for-  --   composing help text components.-  module Options.Applicative.Help.Chunk,--  -- | Types required by the help system.-  module Options.Applicative.Help.Types,--  -- | Core implementation of the help text-  --   generator.-  module Options.Applicative.Help.Core,--  -- | 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
− Options/Applicative/Help/Chunk.hs 
@@ -1,142 +0,0 @@-module Options.Applicative.Help.Chunk-  ( mappendWith-  , Chunk(..)-  , chunked-  , listToChunk-  , (<<+>>)-  , (<</>>)-  , vcatChunks-  , vsepChunks-  , isEmpty-  , stringChunk-  , paragraph-  , extractChunk-  , tabulate-  ) where--import Control.Applicative-import Control.Monad-import Data.Maybe-import Data.Semigroup-import Prelude--import Options.Applicative.Help.Pretty--mappendWith :: Monoid a => a -> a -> a -> a-mappendWith s x y = mconcat [x, s, y]---- | The free monoid on a semigroup 'a'.-newtype Chunk a = Chunk-  { unChunk :: Maybe a }-  deriving (Eq, Show)--instance Functor Chunk where-  fmap f = Chunk . fmap f . unChunk--instance Applicative Chunk where-  pure = Chunk . pure-  Chunk f <*> Chunk x = Chunk (f <*> x)--instance Alternative Chunk where-  empty = Chunk Control.Applicative.empty-  a <|> b = Chunk $ unChunk a <|> unChunk b--instance Monad Chunk where-  return = pure-  m >>= f = Chunk $ unChunk m >>= unChunk . f--instance Monoid a => Semigroup (Chunk a) where-  (<>) = chunked mappend--instance Monoid a => Monoid (Chunk a) where-  mempty = Chunk Nothing-  mappend = (<>)--instance MonadPlus Chunk where-  mzero = Chunk mzero-  mplus m1 m2 = Chunk $ mplus (unChunk m1) (unChunk m2)---- | 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)---- | 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,177 +0,0 @@-module Options.Applicative.Help.Core (-  cmdDesc,-  briefDesc,-  missingDesc,-  fold_tree,-  fullDesc,-  ParserHelp(..),-  errorHelp,-  headerHelp,-  suggestionsHelp,-  usageHelp,-  bodyHelp,-  footerHelp,-  parserHelp,-  parserUsage,-  ) where--import Control.Applicative-import Control.Monad (guard)-import Data.Function (on)-import Data.List (sort, intersperse, groupBy)-import Data.Maybe (maybeToList, catMaybes, fromMaybe)-import Data.Monoid-import Prelude--import Options.Applicative.Common-import Options.Applicative.Types-import Options.Applicative.Help.Pretty-import Options.Applicative.Help.Chunk---- | Style for rendering an option.-data OptDescStyle = OptDescStyle-  { descSep :: Doc-  , descHidden :: Bool-  , descOptional :: Bool-  , descSurround :: Bool }---- | Generate description for a single option.-optDesc :: ParserPrefs -> OptDescStyle -> OptHelpInfo -> Option a -> Chunk Doc-optDesc pprefs style info opt =-  let ns = optionNames $ optMain opt-      mv = stringChunk $ optMetaVar opt-      descs = map (string . showOption) (sort ns)-      desc' = listToChunk (intersperse (descSep style) descs) <<+>> mv-      show_opt-        | hinfoDefault info && not (descOptional style)-        = False-        | optVisibility opt == Hidden-        = descHidden style-        | otherwise-        = optVisibility opt == Visible-      suffix-        | hinfoMulti info-        = stringChunk . prefMultiSuffix $ pprefs-        | otherwise-        = mempty-      render chunk-        | not show_opt-        = mempty-        | isEmpty chunk || not (descSurround style)-        = mappend chunk suffix-        | hinfoDefault info-        = mappend (fmap brackets chunk) suffix-        | null (drop 1 descs)-        = mappend chunk suffix-        | otherwise-        = mappend (fmap parens chunk) suffix-  in maybe id fmap (optDescMod opt) (render desc')---- | Generate descriptions for commands.-cmdDesc :: Parser a -> [(Maybe String, Chunk Doc)]-cmdDesc = mapParser desc-  where-    desc _ opt =-      case optMain opt of-        CmdReader gn cmds p -> (,) gn $-          tabulate [(string cmd, align (extractChunk d))-                   | cmd <- reverse cmds-                   , d <- maybeToList . fmap infoProgDesc $ p cmd ]-        _ -> mempty---- | Generate a brief help text for a parser.-briefDesc :: ParserPrefs -> Parser a -> Chunk Doc-briefDesc = briefDesc' True---- | Generate a brief help text for a parser, only including mandatory---   options and arguments.-missingDesc :: ParserPrefs -> Parser a -> Chunk Doc-missingDesc = briefDesc' False---- | Generate a brief help text for a parser, allowing the specification---   of if optional arguments are show.-briefDesc' :: Bool -> ParserPrefs -> Parser a -> Chunk Doc-briefDesc' showOptional pprefs = fold_tree . treeMapParser (optDesc pprefs style)-  where-    style = OptDescStyle-      { descSep = string "|"-      , descHidden = False-      , descOptional = showOptional-      , descSurround = True }--fold_tree :: OptTree (Chunk Doc) -> Chunk Doc-fold_tree (Leaf x) = x-fold_tree (MultNode xs) = foldr ((<</>>) . fold_tree) mempty xs-fold_tree (AltNode xs) = alt_node-                       . filter (not . isEmpty)-                       . map fold_tree $ xs-  where-    alt_node :: [Chunk Doc] -> Chunk Doc-    alt_node [n] = n-    alt_node ns = fmap parens-                . foldr (chunked (\x y -> x </> char '|' </> y)) mempty-                $ ns---- | Generate a full help text for a parser.-fullDesc :: ParserPrefs -> Parser a -> Chunk Doc-fullDesc pprefs = tabulate . catMaybes . mapParser doc-  where-    doc info opt = do-      guard . not . isEmpty $ n-      guard . not . isEmpty $ h-      return (extractChunk n, align . extractChunk $ h <<+>> hdef)-      where-        n = optDesc pprefs style info opt-        h = optHelp opt-        hdef = Chunk . fmap show_def . optShowDefault $ opt-        show_def s = parens (string "default:" <+> string s)-    style = OptDescStyle-      { descSep = string ","-      , descHidden = True-      , descOptional = True-      , descSurround = False }--errorHelp :: Chunk Doc -> ParserHelp-errorHelp chunk = mempty { helpError = chunk }--headerHelp :: Chunk Doc -> ParserHelp-headerHelp chunk = mempty { helpHeader = chunk }--suggestionsHelp :: Chunk Doc -> ParserHelp-suggestionsHelp chunk = mempty { helpSuggestions = chunk }--usageHelp :: Chunk Doc -> ParserHelp-usageHelp chunk = mempty { helpUsage = 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 $-  ( with_title "Available options:" (fullDesc pprefs p) )-  : (group_title <$> cs)-  where-    def = "Available commands:"--    cs = groupBy ((==) `on` fst) $ cmdDesc p--    group_title a@((n,_):_) = with_title (fromMaybe def n) $-      vcatChunks (snd <$> a)-    group_title _ = mempty---    with_title :: String -> Chunk Doc -> Chunk Doc-    with_title title = fmap (string title .$.)---- | Generate option summary.-parserUsage :: ParserPrefs -> Parser a -> String -> Doc-parserUsage pprefs p progn = hsep-  [ string "Usage:"-  , string progn-  , align (extractChunk (briefDesc pprefs p)) ]--{-# ANN footerHelp "HLint: ignore Eta reduce" #-}
− Options/Applicative/Help/Levenshtein.hs 
@@ -1,61 +0,0 @@-module Options.Applicative.Help.Levenshtein (-    editDistance-  ) where---- | Calculate the Damerau-Levenshtein edit distance---   between two lists (strings).------   This is modified from---   https://wiki.haskell.org/Edit_distance---   and is originally from Lloyd Allison's paper---   "Lazy Dynamic-Programming can be Eager"------   It's been changed though from Levenshtein to---   Damerau-Levenshtein, which treats transposition---   of adjacent characters as one change instead of---   two.-editDistance :: Eq a => [a] -> [a] -> Int-editDistance a b = last $-  case () of-    _ | lab == 0-     -> mainDiag-      | lab > 0-     -> lowers !! (lab - 1)-      | otherwise-     -> uppers !! (-1 - lab)-  where-    mainDiag = oneDiag a b (head uppers) (-1 : head lowers)-    uppers = eachDiag a b (mainDiag : uppers) -- upper diagonals-    lowers = eachDiag b a (mainDiag : lowers) -- lower diagonals-    eachDiag _ [] _ = []-    eachDiag _ _ [] = []-    eachDiag a' (_:bs) (lastDiag:diags) =-      oneDiag a' bs nextDiag lastDiag : eachDiag a' bs diags-      where-        nextDiag = head (tail diags)-    oneDiag a' b' diagAbove diagBelow = thisdiag-      where-        doDiag [] _ _ _ _ = []-        doDiag _ [] _ _ _ = []-        -- Check for a transposition-        -- We don't add anything to nw here, the next character-        -- will be different however and the transposition-        -- will have an edit distance of 1.-        doDiag (ach:ach':as) (bch:bch':bs) nw n w-          | ach' == bch && ach == bch'-          = nw : (doDiag (ach' : as) (bch' : bs) nw (tail n) (tail w))-        -- Standard case-        doDiag (ach:as) (bch:bs) nw n w =-          me : (doDiag as bs me (tail n) (tail w))-          where-            me =-              if ach == bch-                then nw-                else 1 + min3 (head w) nw (head n)-        firstelt = 1 + head diagBelow-        thisdiag = firstelt : doDiag a' b' firstelt diagAbove (tail diagBelow)-    lab = length a - length b-    min3 x y z =-      if x < y-        then x-        else min y z
− Options/Applicative/Help/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,41 +0,0 @@-module Options.Applicative.Help.Types (-    ParserHelp (..)-  , renderHelp-  ) where--import Data.Semigroup-import Prelude--import Options.Applicative.Help.Chunk-import Options.Applicative.Help.Pretty--data ParserHelp = ParserHelp-  { helpError :: Chunk Doc-  , helpSuggestions :: 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 mempty-  mappend = (<>)--instance Semigroup ParserHelp where-  (ParserHelp e1 s1 h1 u1 b1 f1) <> (ParserHelp e2 s2 h2 u2 b2 f2)-    = ParserHelp (mappend e1 e2) (mappend s1 s2)-                 (mappend h1 h2) (mappend u1 u2)-                 (mappend b1 b2) (mappend f1 f2)--helpText :: ParserHelp -> Doc-helpText (ParserHelp e s h u b f) = extractChunk . vsepChunks $ [e, s, 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,265 +0,0 @@-module Options.Applicative.Internal-  ( P-  , MonadP(..)-  , ParseError(..)--  , uncons-  , hoistMaybe-  , hoistEither-  , runReadM-  , withReadM--  , runP--  , Completion-  , runCompletion-  , contextNames--  , ListT-  , takeListT-  , runListT--  , NondetT-  , cut-  , (<!>)-  , disamb-  ) where--import Control.Applicative-import Prelude-import Control.Monad (MonadPlus(..), liftM, ap, guard)-import Control.Monad.Trans.Class (MonadTrans, lift)-import Control.Monad.Trans.Except-  (runExcept, runExceptT, withExcept, ExceptT(..), throwE)-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)--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,396 +0,0 @@-{-# LANGUAGE Rank2Types, ExistentialQuantification #-}-module Options.Applicative.Types (-  ParseError(..),-  ParserInfo(..),-  ParserPrefs(..),--  Option(..),-  OptName(..),-  OptReader(..),-  OptProperties(..),-  OptVisibility(..),-  ReadM(..),-  readerAsk,-  readerAbort,-  readerError,-  CReader(..),-  Parser(..),-  ParserM(..),-  Completer(..),-  mkCompleter,-  CompletionResult(..),-  ParserFailure(..),-  ParserResult(..),-  overFailure,-  Args,-  ArgPolicy(..),-  OptHelpInfo(..),-  OptTree(..),-  ParserHelp(..),-  SomeParser(..),-  Context(..),-  IsCmdStart(..),--  fromM,-  oneM,-  manyM,-  someM,--  optVisibility,-  optMetaVar,-  optHelp,-  optShowDefault,-  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-  | 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) }---- | Global preferences for a top-level 'Parser'.-data ParserPrefs = ParserPrefs-  { prefMultiSuffix :: String    -- ^ metavar suffix for multiple options-  , prefDisambiguate :: Bool     -- ^ automatically disambiguate abbreviations-                                 -- (default: False)-  , prefShowHelpOnError :: Bool  -- ^ always show help text on parse errors-                                 -- (default: False)-  , prefShowHelpOnEmpty :: Bool  -- ^ show the help text for a command or subcommand-                                 -- if it fails with no input (default: False)-  , prefBacktrack :: Bool        -- ^ backtrack to parent parser when a-                                 -- subcommand fails (default: True)-  , prefColumns :: Int           -- ^ number of columns in the terminal, used to-                                 -- format the help page (default: 80)-  } deriving (Eq, Show)--data OptName = OptShort !Char-             | OptLong !String-  deriving (Eq, Ord, Show)---- | Visibility of an option in the help text.-data OptVisibility-  = Internal          -- ^ does not appear in the help text at all-  | Hidden            -- ^ only visible in the full description-  | Visible           -- ^ visible both in the full and brief descriptions-  deriving (Eq, Ord, Show)---- | Specification for an individual parser option.-data OptProperties = OptProperties-  { propVisibility :: OptVisibility       -- ^ whether this flag is shown is the brief description-  , propHelp :: Chunk Doc                 -- ^ help text for this option-  , propMetaVar :: String                 -- ^ metavariable for this option-  , propShowDefault :: Maybe String       -- ^ what to show in the help text as the default-  , propDescMod :: Maybe ( Doc -> Doc )   -- ^ a function to run over the brief description-  }--instance Show OptProperties where-  showsPrec p (OptProperties pV pH pMV pSD _)-    = showParen (p >= 11)-    $ showString "OptProperties { propVisibility = " . shows pV-    . showString ", propHelp = " . shows pH-    . showString ", propMetaVar = " . shows pMV-    . showString ", propShowDefault = " . shows pSD-    . showString ", propDescMod = _ }"---- | A single option of a parser.-data Option a = Option-  { optMain :: OptReader a               -- ^ reader for this option-  , optProps :: OptProperties            -- ^ properties of this option-  }--data SomeParser = forall a . SomeParser (Parser a)---- | Subparser context, containing the 'name' of the subparser, and its parser info.---   Used by parserFailure to display relevant usage information when parsing inside a subparser fails.-data Context = forall a . Context String (ParserInfo a)--instance Show (Option a) where-    show opt = "Option {optProps = " ++ show (optProps opt) ++ "}"--instance Functor Option where-  fmap f (Option m p) = Option (fmap f m) p---- | A newtype over 'ReaderT String Except', used by option readers.-newtype ReadM a = ReadM-  { unReadM :: ReaderT String (Except ParseError) a }--instance Functor ReadM where-  fmap f (ReadM r) = ReadM (fmap f r)--instance Applicative ReadM where-  pure = ReadM . pure-  ReadM x <*> ReadM y = ReadM $ x <*> y--instance Alternative ReadM where-  empty = mzero-  (<|>) = mplus--instance Monad ReadM where-  return = pure-  ReadM r >>= f = ReadM $ r >>= unReadM . f-  fail = Fail.fail--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] (String -> Maybe (ParserInfo a))-  -- ^ command reader--instance Functor OptReader where-  fmap f (OptReader ns cr e) = OptReader ns (fmap f cr) e-  fmap f (FlagReader ns x) = FlagReader ns (f x)-  fmap f (ArgReader cr) = ArgReader (fmap f cr)-  fmap f (CmdReader n cs g) = CmdReader n cs ((fmap . fmap) f . g)---- | A @Parser a@ is an option parser returning a value of type 'a'.-data Parser a-  = NilP (Maybe a)-  | OptP (Option a)-  | forall x . MultP (Parser (x -> a)) (Parser x)-  | AltP (Parser a) (Parser a)-  | forall x . BindP (Parser x) (x -> Parser a)--instance Functor Parser where-  fmap f (NilP x) = NilP (fmap f x)-  fmap f (OptP opt) = OptP (fmap f opt)-  fmap f (MultP p1 p2) = MultP (fmap (f.) p1) p2-  fmap f (AltP p1 p2) = AltP (fmap f p1) (fmap f p2)-  fmap f (BindP p k) = BindP p (fmap f . k)--instance Applicative Parser where-  pure = NilP . Just-  (<*>) = MultP--newtype ParserM r = ParserM-  { runParserM :: forall x . (r -> Parser x) -> Parser x }--instance Monad ParserM where-  return = 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 p = fromM $ manyM p-  some p = fromM $ (:) <$> oneM p <*> manyM p---- | A shell complete function.-newtype Completer = Completer-  { runCompleter :: String -> IO [String] }---- | Smart constructor for a 'Completer'-mkCompleter :: (String -> IO [String]) -> Completer-mkCompleter = Completer--instance Semigroup Completer where-  (Completer c1) <> (Completer c2) =-    Completer $ \s -> (++) <$> c1 s <*> c2 s--instance Monoid Completer where-  mempty = Completer $ \_ -> return []-  mappend = (<>)--newtype CompletionResult = CompletionResult-  { execCompletion :: String -> IO String }--instance Show CompletionResult where-  showsPrec p _ = showParen (p > 10) $-    showString "CompletionResult _"--newtype ParserFailure h = ParserFailure-  { execFailure :: String -> (h, ExitCode, Int) }--instance Show h => Show (ParserFailure h) where-  showsPrec p (ParserFailure f)-    = showParen (p > 10)-    $ showString "ParserFailure "-    . showsPrec 11 (f "<program>")--instance Functor ParserFailure where-  fmap f (ParserFailure err) = ParserFailure $ \progn ->-    let (h, exit, cols) = err progn in (f h, exit, cols)---- | Result of 'execParserPure'.-data ParserResult a-  = Success a-  | Failure (ParserFailure ParserHelp)-  | CompletionInvoked CompletionResult-  deriving Show--instance Functor ParserResult where-  fmap f (Success a) = Success (f a)-  fmap _ (Failure f) = Failure f-  fmap _ (CompletionInvoked c) = CompletionInvoked c--overFailure :: (ParserHelp -> ParserHelp)-            -> ParserResult a -> ParserResult a-overFailure f (Failure failure) = Failure $ fmap f failure-overFailure _ r = r--instance Applicative ParserResult where-  pure = Success-  Success f <*> r = fmap f r-  Failure f <*> _ = Failure f-  CompletionInvoked c <*> _ = CompletionInvoked c--instance Monad ParserResult where-  return = pure-  Success x >>= f = f x-  Failure f >>= _ = Failure f-  CompletionInvoked c >>= _ = CompletionInvoked c--type Args = [String]---- | Policy for how to handle options within the parse-data ArgPolicy-  = Intersperse-  -- ^ The default policy, options and arguments can-  --   be interspersed.-  --   A `--` option can be passed to ensure all following-  --   commands are treated as arguments.-  | NoIntersperse-  -- ^ Options must all come before arguments, once a-  --   single positional argument or subcommand is parsed,-  --   all remaining arguments are treated as positionals.-  --   A `--` option can be passed if the first positional-  --   one needs starts with `-`.-  | AllPositionals-  -- ^ No options are parsed at all, all arguments are-  --   treated as positionals.-  --   Is the policy used after `--` is encountered.-  | ForwardOptions-  -- ^ Options and arguments can be interspersed, but if-  --   a given option is not found, it is treated as a-  --   positional argument. This is sometimes useful if-  --   one is passing through most options to another tool,-  --   but are supplying just a few of their own options.-  deriving (Eq, Ord, Show)--data OptHelpInfo = OptHelpInfo-  { hinfoMulti :: Bool    -- ^ Whether this is part of a many or some (approximately)-  , hinfoDefault :: Bool  -- ^ Whether this option has a default value-  , hinfoUnreachableArgs :: Bool -- ^ If the result is a positional, if it can't be-                                 --   accessed in the current parser position ( first arg )-  } deriving (Eq, Show)--data OptTree a-  = 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--optDescMod :: Option a -> Maybe ( Doc -> Doc )-optDescMod = propDescMod . optProps
optparse-applicative.cabal view
@@ -1,5 +1,5 @@ name:                optparse-applicative-version:             0.14.3.0+version:             0.15.0.0 synopsis:            Utilities and combinators for parsing command line options description:     optparse-applicative is a haskell library for parsing options@@ -34,23 +34,41 @@                      tests/hello.err.txt                      tests/helponempty.err.txt                      tests/helponemptysub.err.txt+                     tests/long_equals.err.txt                      tests/formatting.err.txt                      tests/nested.err.txt+                     tests/optional.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==7.0.4,+  GHC==7.2.2,+  GHC==7.4.2,+  GHC==7.6.3,+  GHC==7.8.4,+  GHC==7.10.3,+  GHC==8.0.2,+  GHC==8.2.2,+  GHC==8.4.4,+  GHC==8.6.5,+  GHC==8.8.1  source-repository head   type:     git   location: https://github.com/pcapriotti/optparse-applicative.git  library+  hs-source-dirs:      src   ghc-options:         -Wall    -- See https://ghc.haskell.org/trac/ghc/wiki/Migration/8.0#base-4.9.0.0   if impl(ghc >= 8.0)-    ghc-options:  -Wno-redundant-constraints -Wcompat -Wnoncanonical-monad-instances -Wnoncanonical-monadfail-instances+    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@@ -73,13 +91,13 @@                      , transformers                    >= 0.2 && < 0.6                      , transformers-compat             >= 0.3 && < 0.7                      , process                         >= 1.0 && < 1.7-                     , ansi-wl-pprint                  >= 0.6.6 && < 0.7+                     , ansi-wl-pprint                  >= 0.6.8 && < 0.7    if !impl(ghc >= 8)-    build-depends:     semigroups                      >= 0.10 && < 0.19+    build-depends:     semigroups                      >= 0.10 && < 0.20                      , fail                            == 4.9.* -test-suite optparse-applicative-tests+test-suite tests   type:                exitcode-stdio-1.0    main-is:             test.hs@@ -96,9 +114,9 @@                      , Examples.Hello    build-depends:       base-                     , bytestring                      == 0.10.*+                     , bytestring                      >= 0.9 && < 0.11                      , optparse-applicative-                     , QuickCheck                      >= 2.8 && < 2.13+                     , QuickCheck                      >= 2.8 && < 2.14    if !impl(ghc >= 8)     build-depends:     semigroups
+ src/Options/Applicative.hs view
@@ -0,0 +1,235 @@+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,++  -- ** Modifiers+  --+  -- | 'Parser' builders take a modifier, which represents a modification of the+  -- properties of an option, and can be composed as a monoid.+  --+  -- Contraints are often used to ensure that the modifiers can be sensibly applied.+  -- For example, positional arguments can't be specified by long or short names,+  -- so the 'HasName' constraint is used to ensure we have a flag or option.+  Mod,++  short,+  long,+  help,+  helpDoc,+  value,+  showDefaultWith,+  showDefault,+  metavar,+  noArgError,+  hidden,+  internal,+  style,+  command,+  commandGroup,+  completeWith,+  action,+  completer,+  idm,+  mappend,++  OptionFields,+  FlagFields,+  ArgumentFields,+  CommandFields,++  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 'ByteString' and 'Text'; and 'auto', which uses the 'Read'+  -- typeclass, and is good for simple types like 'Int' or 'Double'.+  --+  -- More complex types can use the 'eitherReader' or 'maybeReader'+  -- functions to pattern match or use a more expressive parser like a+  -- member of the 'Parsec' family.+  ReadM,++  auto,+  str,+  maybeReader,+  eitherReader,+  disabled,+  readerAbort,+  readerError,++  -- * Program descriptions+  --+  -- ** 'ParserInfo'+  --+  -- | A 'ParserInfo' describes a command line program, used to generate a help+  -- screen. Two help modes are supported: brief and full. In brief mode, only+  -- an option and argument summary is displayed, while in full mode each+  -- available option and command, including hidden ones, is described.+  --+  -- A 'ParserInfo' should be created with the 'info' function and a set of+  -- 'InfoMod' modifiers.+  --+  info,++  ParserInfo(..),++  InfoMod,+  fullDesc,+  briefDesc,+  header,+  headerDoc,+  footer,+  footerDoc,+  progDesc,+  progDescDoc,+  failureCode,+  noIntersperse,+  forwardOptions,++  -- * Running parsers+  --+  -- | The execParser family of functions are used to run parsers+  execParser,+  customExecParser,+  execParserPure,++  -- ** Handling parser results manually+  getParseResult,+  handleParseResult,+  parserFailure,+  renderFailure,+  overFailure,++  -- ** 'ParserPrefs'+  --+  -- | A 'ParserPrefs' contains general preferences for all command-line+  -- options, and should be built with the 'prefs' function.+  prefs,++  ParserPrefs(..),++  PrefsMod,+  multiSuffix,+  disambiguate,+  showHelpOnError,+  showHelpOnEmpty,+  noBacktrack,+  subparserInline,+  columns,+  helpLongEquals,+  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,256 @@+-- | You don't need to import this module to enable bash completion.+--+-- See+-- <http://github.com/pcapriotti/optparse-applicative/wiki/Bash-Completion the wiki>+-- for more information on bash completion.+module Options.Applicative.BashCompletion+  ( bashCompletionParser+  ) where++import Control.Applicative+import Prelude+import Data.Foldable ( asum )+import Data.List ( isPrefixOf )+import Data.Maybe ( fromMaybe, listToMaybe )++import Options.Applicative.Builder+import Options.Applicative.Common+import Options.Applicative.Internal+import Options.Applicative.Types+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+    failure opts = CompletionResult+      { execCompletion = \progn -> unlines <$> opts progn }++    complParser = asum+      [ failure <$>+        (  bashCompletionQuery pinfo pprefs+        -- To get rich completions, one just needs the first+        -- command. To customise the lengths, use either of+        -- the `desc-length` options.+        -- zsh commands can go on a single line, so they might+        -- want to be longer.+        <$> ( flag' Enriched (long "bash-completion-enriched" `mappend` internal)+                <*> option auto (long "bash-completion-option-desc-length" `mappend` internal `mappend` value 40)+                <*> option auto (long "bash-completion-command-desc-length" `mappend` internal `mappend` value 40)+          <|> pure Standard+          )+        <*> (many . strOption) (long "bash-completion-word"+                                  `mappend` internal)+        <*> option auto (long "bash-completion-index" `mappend` internal) )+      , failure <$>+          (bashCompletionScript <$>+            strOption (long "bash-completion-script" `mappend` internal))+      , failure <$>+          (fishCompletionScript <$>+            strOption (long "fish-completion-script" `mappend` internal))+      , failure <$>+          (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 hinfo opt = case optMain opt of+      OptReader ns _ _+         | argPolicy /= AllPositionals+        -> return . add_opt_help opt $ show_names ns+         | otherwise+        -> return []+      FlagReader ns _+         | argPolicy /= AllPositionals+        -> return . add_opt_help opt $ show_names ns+         | otherwise+        -> return []+      ArgReader rdr+         | hinfoUnreachableArgs hinfo+        -> return []+         | otherwise+        -> run_completer (crCompleter rdr)+      CmdReader _ ns p+         | hinfoUnreachableArgs hinfo+        -> return []+         | otherwise+        -> return . add_cmd_help p $ filter_names ns++    -- When doing enriched completions, add any help specified+    -- to the completion variables (tab separated).+    add_opt_help :: Functor f => Option a -> f String -> f String+    add_opt_help opt = case richness of+      Standard ->+        id+      Enriched len _ ->+        fmap $ \o ->+          let h = unChunk $ optHelp opt+          in  maybe o (\h' -> o ++ "\t" ++ render_line len h') h++    -- When doing enriched completions, add the command description+    -- to the completion variables (tab separated).+    add_cmd_help :: Functor f => (String -> Maybe (ParserInfo a)) -> f String -> f String+    add_cmd_help p = case richness of+      Standard ->+        id+      Enriched _ len ->+        fmap $ \cmd ->+          let h = p cmd >>= unChunk . infoProgDesc+          in  maybe cmd (\h' -> cmd ++ "\t" ++ render_line len h') h++    show_names :: [OptName] -> [String]+    show_names = filter_names . map showOption++    -- We only want to show a single line in the completion results description.+    -- If there was a line break, it would come across as a different completion+    -- possibility.+    render_line :: Int -> Doc -> String+    render_line len doc = case lines (displayS (renderPretty 1 len doc) "") of+      [] -> ""+      [x] -> x+      x : _ -> x ++ "..."++    filter_names :: [String] -> [String]+    filter_names = filter is_completion++    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++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 ]++{-+/Note/: Fish Shell++Derived from Drezil's post in #169.++@+commandline+-c or --cut-at-cursor only print selection up until the current cursor position+-o or --tokenize tokenize the selection and print one string-type token per line+@++We tokenize so that the call to count (and hence --bash-completion-index)+gets the right number use cut-at-curstor to not bother sending anything+after the cursor position, which allows for completion of the middle of+words.++Tab characters separate items from descriptions.+-}+fishCompletionScript :: String -> String -> IO [String]+fishCompletionScript prog progn = return+  [ " function _" ++ progn+  , "    set -l cl (commandline --tokenize --current-process)"+  , "    # Hack around fish issue #3934"+  , "    set -l cn (commandline --tokenize --cut-at-cursor --current-process)"+  , "    set -l cn (count $cn)"+  , "    set -l tmpline --bash-completion-enriched --bash-completion-index $cn"+  , "    for arg in $cl"+  , "      set tmpline $tmpline --bash-completion-word $arg"+  , "    end"+  , "    for opt in (" ++ prog ++ " $tmpline)"+  , "      if test -d $opt"+  , "        echo -E \"$opt/\""+  , "      else"+  , "        echo -E \"$opt\""+  , "      end"+  , "    end"+  , "end"+  , ""+  , "complete --no-files --command " ++ progn ++ " --arguments '(_"  ++ progn ++  ")'"+  ]++zshCompletionScript :: String -> String -> IO [String]+zshCompletionScript prog progn = return+  [ "#compdef " ++ progn+  , ""+  , "local request"+  , "local completions"+  , "local word"+  , "local index=$((CURRENT - 1))"+  , ""+  , "request=(--bash-completion-enriched --bash-completion-index $index)"+  , "for arg in ${words[@]}; do"+  , "  request=(${request[@]} --bash-completion-word $arg)"+  , "done"+  , ""+  , "IFS=$'\\n' completions=($( " ++ prog ++ " \"${request[@]}\" ))"+  , ""+  , "for word in $completions; do"+  , "  local -a parts"+  , ""+  , "  # Split the line at a tab if there is one."+  , "  IFS=$'\\t' parts=($( echo $word ))"+  , ""+  , "  if [[ -n $parts[2] ]]; then"+  , "     if [[ $word[1] == \"-\" ]]; then"+  , "       local desc=(\"$parts[1] ($parts[2])\")"+  , "       compadd -d desc -- $parts[1]"+  , "     else"+  , "       local desc=($(print -f  \"%-019s -- %s\" $parts[1] $parts[2]))"+  , "       compadd -l -d desc -- $parts[1]"+  , "     fi"+  , "  else"+  , "    compadd -f -- $word"+  , "  fi"+  , "done"+  ]
+ src/Options/Applicative/Builder.hs view
@@ -0,0 +1,530 @@+module Options.Applicative.Builder (+  -- * Parser builders+  --+  -- | This module contains utility functions and combinators to create parsers+  -- for individual options.+  --+  -- Each parser builder takes an option modifier. A modifier can be created by+  -- composing the basic modifiers provided by this module using the 'Monoid'+  -- operations 'mempty' and 'mappend', or their aliases 'idm' and '<>'.+  --+  -- For example:+  --+  -- > out = strOption+  -- >     ( long "output"+  -- >    <> short 'o'+  -- >    <> metavar "FILENAME" )+  --+  -- creates a parser for an option called \"output\".+  subparser,+  strArgument,+  argument,+  flag,+  flag',+  switch,+  abortOption,+  infoOption,+  strOption,+  option,+  nullOption,++  -- * Modifiers+  short,+  long,+  help,+  helpDoc,+  value,+  showDefaultWith,+  showDefault,+  metavar,+  noArgError,+  ParseError(..),+  hidden,+  internal,+  style,+  command,+  commandGroup,+  completeWith,+  action,+  completer,+  idm,+  mappend,++  -- * Readers+  --+  -- | A collection of basic 'Option' readers.+  auto,+  str,+  maybeReader,+  eitherReader,+  disabled,+  readerAbort,+  readerError,++  -- * Builder for 'ParserInfo'+  InfoMod,+  fullDesc,+  briefDesc,+  header,+  headerDoc,+  footer,+  footerDoc,+  progDesc,+  progDescDoc,+  failureCode,+  noIntersperse,+  forwardOptions,+  info,++  -- * Builder for 'ParserPrefs'+  PrefsMod,+  multiSuffix,+  disambiguate,+  showHelpOnError,+  showHelpOnEmpty,+  noBacktrack,+  subparserInline,+  columns,+  helpLongEquals,+  prefs,+  defaultPrefs,++  -- * Types+  Mod,+  ReadM,+  OptionFields,+  FlagFields,+  ArgumentFields,+  CommandFields,++  HasName,+  HasCompleter,+  HasValue,+  HasMetavar+  ) where++import Control.Applicative+import Data.Semigroup hiding (option)+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++-- 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 'Text.PrettyPrint.ANSI.Leijen.Doc'+-- value.+helpDoc :: Maybe Doc -> Mod f a+helpDoc doc = optionMod $ \p -> p { propHelp = Chunk doc }++-- | Specify the error to display when no argument is provided to this option.+noArgError :: ParseError -> Mod OptionFields a+noArgError e = fieldMod $ \p -> p { optNoArgError = 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.+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 bold)+--+-- /NOTE/: This builder is more flexible than its name and example+-- allude. One of the motivating examples for its addition was to+-- used `const` to completely replace the usage text of an option.+style :: ( Doc -> Doc ) -> Mod f a+style x = optionMod $ \p ->+  p { propDescMod = Just x }++-- | Add a command to a subparser option.+--+-- Suggested usage for multiple commands is to add them to a single subparser. e.g.+--+-- @+-- sample :: Parser Sample+-- sample = subparser+--        ( command "hello"+--          (info hello (progDesc "Print greeting"))+--       <> command "goodbye"+--          (info goodbye (progDesc "Say goodbye"))+--        )+-- @+command :: String -> ParserInfo a -> Mod CommandFields a+command cmd pinfo = fieldMod $ \p ->+  p { cmdCommands = (cmd, pinfo) : cmdCommands p }++-- | Add a description to a group of commands.+--+-- Advanced feature for separating logical groups of commands on the parse line.+--+-- If using the same `metavar` for each group of commands, it may yield a more+-- attractive usage text combined with `hidden` for some groups.+commandGroup :: String -> Mod CommandFields a+commandGroup g = fieldMod $ \p ->+  p { cmdGroup = Just g }++-- | Add a list of possible completion values.+completeWith :: HasCompleter f => [String] -> Mod f a+completeWith = 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.+subparser :: Mod CommandFields a -> Parser a+subparser m = mkParser d g rdr+  where+    Mod _ d g = metavar "COMMAND" `mappend` m+    (groupName, cmds, subs) = mkCommand m+    rdr = CmdReader groupName cmds subs++-- | Builder for an argument parser.+argument :: ReadM a -> Mod ArgumentFields a -> Parser a+argument p (Mod f d g) = mkParser d g (ArgReader rdr)+  where+    ArgumentFields compl = f (ArgumentFields mempty)+    rdr = CReader compl p++-- | Builder for a 'String' argument.+strArgument :: 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++-- | Same as 'option'.+{-# DEPRECATED nullOption "Use 'option' instead" #-}+nullOption :: ReadM a -> Mod OptionFields a -> Parser a+nullOption = option++-- | Builder for an option using the given reader.+--+-- This is a regular option, and should always have either a @long@ or+-- @short@ name specified in the modifiers (or both).+--+-- > nameParser = option str ( long "name" <> short 'n' )+--+option :: ReadM a -> Mod OptionFields a -> Parser a+option r m = mkParser d g rdr+  where+    Mod f d g = metavar "ARG" `mappend` m+    fields = f (OptionFields [] mempty ExpectsArgError)+    crdr = CReader (optCompleter fields) r+    rdr = OptReader (optNames fields) crdr (optNoArgError fields)++-- | Modifier for 'ParserInfo'.+newtype InfoMod a = InfoMod+  { applyInfoMod :: ParserInfo a -> ParserInfo a }++instance Monoid (InfoMod a) where+  mempty = InfoMod id+  mappend = (<>)++instance Semigroup (InfoMod a) where+  m1 <> m2 = InfoMod $ applyInfoMod m2 . applyInfoMod m1++-- | Show a full description in the help text of this parser.+fullDesc :: InfoMod a+fullDesc = InfoMod $ \i -> i { infoFullDesc = True }++-- | Only show a brief description in the help text of this parser.+briefDesc :: InfoMod a+briefDesc = InfoMod $ \i -> i { infoFullDesc = False }++-- | Specify a header for this parser.+header :: String -> InfoMod a+header s = InfoMod $ \i -> i { infoHeader = paragraph s }++-- | Specify a header for this parser as a 'Text.PrettyPrint.ANSI.Leijen.Doc'+-- value.+headerDoc :: Maybe Doc -> InfoMod a+headerDoc doc = InfoMod $ \i -> i { infoHeader = Chunk doc }++-- | Specify a footer for this parser.+footer :: String -> InfoMod a+footer s = InfoMod $ \i -> i { infoFooter = paragraph s }++-- | Specify a footer for this parser as a 'Text.PrettyPrint.ANSI.Leijen.Doc'+-- value.+footerDoc :: Maybe Doc -> InfoMod a+footerDoc doc = InfoMod $ \i -> i { infoFooter = Chunk doc }++-- | Specify a short program description.+progDesc :: String -> InfoMod a+progDesc s = InfoMod $ \i -> i { infoProgDesc = paragraph s }++-- | Specify a short program description as a 'Text.PrettyPrint.ANSI.Leijen.Doc'+-- value.+progDescDoc :: Maybe Doc -> InfoMod a+progDescDoc doc = InfoMod $ \i -> i { infoProgDesc = Chunk doc }++-- | Specify an exit code if a parse error occurs.+failureCode :: Int -> InfoMod a+failureCode n = InfoMod $ \i -> i { infoFailureCode = n }++-- | Disable parsing of regular options after arguments. 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 }++-- | 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 }++-- | 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 }++-- 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,122 @@+module Options.Applicative.Builder.Completer+  ( Completer+  , mkCompleter+  , listIOCompleter+  , listCompleter+  , bashCompleter+  ) where++import Control.Applicative+import Prelude+import Control.Exception (IOException, try)+import Data.List (isPrefixOf)+import System.Process (readProcess)++import Options.Applicative.Types++-- | Create a 'Completer' from an IO action+listIOCompleter :: IO [String] -> Completer+listIOCompleter ss = Completer $ \s ->+  filter (isPrefixOf s) <$> ss++-- | Create a 'Completer' from a constant+-- list of strings.+listCompleter :: [String] -> Completer+listCompleter = listIOCompleter . pure++-- | Run a compgen completion action.+--+-- Common actions include @file@ and+-- @directory@. See+-- <http://www.gnu.org/software/bash/manual/html_node/Programmable-Completion-Builtins.html#Programmable-Completion-Builtins>+-- for a complete list.+bashCompleter :: String -> Completer+bashCompleter action = Completer $ \word -> do+  let cmd = unwords ["compgen", "-A", action, "--", requote word]+  result <- tryIO $ readProcess "bash" ["-c", cmd] ""+  return . lines . either (const []) id $ result++tryIO :: IO a -> IO (Either IOException a)+tryIO = try++-- | Strongly quote the string we pass to compgen.+--+-- We need to do this so bash doesn't expand out any ~ or other+-- chars we want to complete on, or emit an end of line error+-- when seeking the close to the quote.+requote :: String -> String+requote s =+  let+    -- Bash doesn't appear to allow "mixed" escaping+    -- in bash completions. So we don't have to really+    -- worry about people swapping between strong and+    -- weak quotes.+    unescaped =+      case s of+        -- It's already strongly quoted, so we+        -- can use it mostly as is, but we must+        -- ensure it's closed off at the end and+        -- there's no single quotes in the+        -- middle which might confuse bash.+        ('\'': rs) -> unescapeN rs++        -- We're weakly quoted.+        ('"': rs)  -> unescapeD rs++        -- We're not quoted at all.+        -- We need to unescape some characters like+        -- spaces and quotation marks.+        elsewise   -> unescapeU elsewise+  in+    strong unescaped++  where+    strong ss = '\'' : foldr go "'" ss+      where+        -- If there's a single quote inside the+        -- command: exit from the strong quote and+        -- emit it the quote escaped, then resume.+        go '\'' t = "'\\''" ++ t+        go h t    = h : t++    -- Unescape a strongly quoted string+    -- We have two recursive functions, as we+    -- can enter and exit the strong escaping.+    unescapeN = goX+      where+        goX ('\'' : xs) = goN xs+        goX (x : xs) = x : goX xs+        goX [] = []++        goN ('\\' : '\'' : xs) = '\'' : goN xs+        goN ('\'' : xs) = goX xs+        goN (x : xs) = x : goN xs+        goN [] = []++    -- Unescape an unquoted string+    unescapeU = goX+      where+        goX [] = []+        goX ('\\' : x : xs) = x : goX xs+        goX (x : xs) = x : goX xs++    -- Unescape a weakly quoted string+    unescapeD = goX+      where+        -- Reached an escape character+        goX ('\\' : x : xs)+          -- If it's true escapable, strip the+          -- slashes, as we're going to strong+          -- escape instead.+          | x `elem` "$`\"\\\n" = x : goX xs+          | otherwise = '\\' : x : goX xs+        -- We've ended quoted section, so we+        -- don't recurse on goX, it's done.+        goX ('"' : xs)+          = xs+        -- Not done, but not a special character+        -- just continue the fold.+        goX (x : xs)+          = x : goX xs+        goX []+          = []
+ src/Options/Applicative/Builder/Internal.hs view
@@ -0,0 +1,185 @@+module Options.Applicative.Builder.Internal (+  -- * Internals+  Mod(..),+  HasName(..),+  HasCompleter(..),+  HasValue(..),+  HasMetavar(..),+  OptionFields(..),+  FlagFields(..),+  CommandFields(..),+  ArgumentFields(..),+  DefaultProp(..),++  optionMod,+  fieldMod,++  baseProps,+  mkCommand,+  mkParser,+  mkOption,+  mkProps,++  internal+  ) where++import Control.Applicative+import Control.Monad (mplus)+import Data.Semigroup hiding (Option)+import Prelude++import Options.Applicative.Common+import Options.Applicative.Types++data OptionFields a = OptionFields+  { optNames :: [OptName]+  , optCompleter :: Completer+  , optNoArgError :: 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 'strOption' or 'flag') to+-- create options (see 'Options.Applicative.Builder').+data Mod f a = Mod (f a -> f a)+                   (DefaultProp a)+                   (OptProperties -> OptProperties)++optionMod :: (OptProperties -> OptProperties) -> Mod f a+optionMod = Mod id mempty++fieldMod :: (f a -> f a) -> Mod f a+fieldMod f = Mod f mempty id++instance Monoid (Mod f a) where+  mempty = Mod id mempty id+  mappend = (<>)++-- | @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+  }++mkCommand :: Mod CommandFields a -> (Maybe String, [String], String -> Maybe (ParserInfo a))+mkCommand m = (group, map fst cmds, (`lookup` cmds))+  where+    Mod f _ _ = m+    CommandFields cmds group = f (CommandFields [] Nothing)++mkParser :: DefaultProp a+         -> (OptProperties -> OptProperties)+         -> OptReader a+         -> Parser a+mkParser d@(DefaultProp def _) g rdr =+  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 from the help text+internal :: Mod f a+internal = optionMod $ \p -> p { propVisibility = Internal }
+ src/Options/Applicative/Common.hs view
@@ -0,0 +1,314 @@+{-# LANGUAGE Rank2Types #-}+module Options.Applicative.Common (+  -- * Option parsers+  --+  -- | A 'Parser' is composed of a list of options. Several kinds of options+  -- are supported:+  --+  --  * Flags: simple no-argument options. When a flag is encountered on the+  --  command line, its value is returned.+  --+  --  * Options: options with an argument. An option can define a /reader/,+  --  which converts its argument from String to the desired value, or throws a+  --  parse error if the argument does not validate correctly.+  --+  --  * Arguments: positional arguments, validated in the same way as option+  --  arguments.+  --+  --  * Commands. A command defines a completely independent sub-parser. When a+  --  command is encountered, the whole command line is passed to the+  --  corresponding parser.+  --+  Parser,+  liftOpt,+  showOption,++  -- * Program descriptions+  --+  -- A 'ParserInfo' describes a command line program, used to generate a help+  -- screen. Two help modes are supported: brief and full. In brief mode, only+  -- an option and argument summary is displayed, while in full mode each+  -- available option and command, including hidden ones, is described.+  --+  -- A basic 'ParserInfo' with default values for fields can be created using+  -- the 'info' function.+  --+  -- A 'ParserPrefs' contains general preferences for all command-line+  -- options, and can be built with the 'prefs' function.+  ParserInfo(..),+  ParserPrefs(..),++  -- * Running parsers+  runParserInfo,+  runParserFully,+  runParser,+  evalParser,++  -- * Low-level utilities+  mapParser,+  treeMapParser,+  optionNames+  ) where++import Control.Applicative+import Control.Monad (guard, mzero, msum, when)+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 _ _ f ->+      case (f arg, prefBacktrack prefs) of+        (Just subp, NoBacktrack) -> lift $ do+          args <- get <* put []+          fmap pure . lift $ enterContext arg subp *> runParserInfo subp args <* exitContext++        (Just subp, Backtrack) -> fmap pure . lift . StateT $ \args ->+          enterContext arg subp *> runParser (infoPolicy subp) CmdStart (infoParser subp) args <* exitContext++        (Just subp, SubparserInline) -> lift $ do+          lift $ enterContext arg subp+          return $ infoParser subp++        (Nothing, _)  -> mzero+    ArgReader rdr ->+      fmap pure . lift . lift $ runReadM (crReader rdr) arg+    _ -> mzero++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+    prefs <- getPrefs+    (mp', args') <- do_step prefs 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 prefs arg argt = (`runStateT` argt)+                           . disamb (not (prefDisambiguate prefs))+                           $ stepParser prefs policy arg p++    newPolicy a = case policy of+      NoIntersperse -> if isJust (parseWord a) then NoIntersperse else AllPositionals+      x             -> x++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. OptHelpInfo -> Option x -> b)+          -> Parser a -> [b]+mapParser f = flatten . treeMapParser f+  where+    flatten (Leaf x) = [x]+    flatten (MultNode xs) = xs >>= flatten+    flatten (AltNode _ xs) = xs >>= flatten++-- | Like 'mapParser', but collect the results in a tree structure.+treeMapParser :: (forall x . OptHelpInfo -> Option x -> b)+          -> Parser a+          -> OptTree b+treeMapParser g = simplify . go False False g+  where+    has_default :: Parser a -> Bool+    has_default p = isJust (evalParser p)++    go :: Bool+       -> Bool+       -> (forall x . OptHelpInfo -> Option x -> b)+       -> Parser a+       -> OptTree b+    go _ _ _ (NilP _) = MultNode []+    go m r f (OptP opt)+      | optVisibility opt > Internal+      = Leaf (f (OptHelpInfo m r) opt)+      | otherwise+      = MultNode []+    go m r f (MultP p1 p2) =+      MultNode [go m r f p1, go m r' f p2]+      where r' = r || hasArg p1+    go m r f (AltP p1 p2) =+      AltNode altNodeType [go m r f p1, go m 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 True r f p+      in case evalParser p of+        Nothing -> go'+        Just aa -> MultNode [ go', go True 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]
+ src/Options/Applicative/Extra.hs view
@@ -0,0 +1,291 @@+{-# LANGUAGE RankNTypes #-}+module Options.Applicative.Extra (+  -- * Extra parser utilities+  --+  -- | This module contains high-level functions to run parsers.+  helper,+  hsubparser,+  execParser,+  execParserMaybe,+  customExecParser,+  customExecParserMaybe,+  execParserPure,+  getParseResult,+  handleParseResult,+  parserFailure,+  renderFailure,+  ParserFailure(..),+  overFailure,+  ParserResult(..),+  ParserPrefs(..),+  CompletionResult(..),+  ) where++import Control.Applicative+import Data.Monoid+import Prelude+import System.Environment (getArgs, getProgName)+import System.Exit (exitSuccess, exitWith, ExitCode(..))+import System.IO (hPutStrLn, stderr)++import Options.Applicative.BashCompletion+import Options.Applicative.Builder+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 = abortOption ShowHelpText $ mconcat+  [ long "help"+  , short 'h'+  , help "Show this help text"+  , hidden ]++-- | Builder for a command parser with a \"helper\" option attached.+-- Used in the same way as `subparser`, but includes a \"--help|-h\" inside+-- the subcommand.+hsubparser :: Mod CommandFields a -> Parser a+hsubparser m = mkParser d g rdr+  where+    Mod _ d g = metavar "COMMAND" `mappend` m+    (groupName, cmds, subs) = mkCommand m+    rdr = CmdReader groupName cmds (fmap add_helper . subs)+    add_helper pinfo = pinfo+      { infoParser = infoParser pinfo <**> helper }++-- | Run a program description.+--+-- Parse command line arguments. Display help text and exit if any parse error+-- occurs.+execParser :: ParserInfo a -> IO a+execParser = customExecParser defaultPrefs++-- | Run a program description with custom preferences.+customExecParser :: ParserPrefs -> ParserInfo a -> IO a+customExecParser pprefs pinfo+  = execParserPure pprefs pinfo <$> getArgs+  >>= handleParseResult++-- | Handle `ParserResult`.+handleParseResult :: ParserResult a -> IO a+handleParseResult (Success a) = return a+handleParseResult (Failure failure) = do+      progn <- getProgName+      let (msg, exit) = renderFailure failure progn+      case exit of+        ExitSuccess -> putStrLn msg+        _           -> hPutStrLn stderr msg+      exitWith exit+handleParseResult (CompletionInvoked compl) = do+      progn <- getProgName+      msg <- execCompletion compl progn+      putStr msg+      exitSuccess++-- | Extract the actual result from a `ParserResult` value.+--+-- This function returns 'Nothing' in case of errors.  Possible error messages+-- or completion actions are simply discarded.+--+-- If you want to display error messages and invoke completion actions+-- appropriately, use 'handleParseResult' instead.+getParseResult :: ParserResult a -> Maybe a+getParseResult (Success a) = Just a+getParseResult _ = Nothing++-- | Run a program description in pure code.+--+-- This function behaves like 'execParser', but can be called from pure code.+-- Note that, in case of errors, no message is displayed, and this function+-- simply returns 'Nothing'.+--+-- If you need to keep track of error messages, use 'execParserPure' instead.+{-# DEPRECATED execParserMaybe "Use execParserPure together with getParseResult instead" #-}+execParserMaybe :: ParserInfo a -> [String] -> Maybe a+execParserMaybe = customExecParserMaybe defaultPrefs++-- | Run a program description with custom preferences in pure code.+--+-- See 'execParserMaybe' for details.+{-# DEPRECATED customExecParserMaybe "Use execParserPure together with getParseResult instead" #-}+customExecParserMaybe :: ParserPrefs -> ParserInfo a -> [String] -> Maybe a+customExecParserMaybe pprefs pinfo args = getParseResult $ execParserPure pprefs pinfo args++-- | The most general way to run a program description in pure code.+execParserPure :: ParserPrefs       -- ^ Global preferences for this parser+               -> ParserInfo a      -- ^ Description of the program to run+               -> [String]          -- ^ Program arguments+               -> ParserResult a+execParserPure pprefs pinfo args =+  case runP p pprefs of+    (Right (Right r), _) -> Success r+    (Right (Left c), _) -> CompletionInvoked c+    (Left err, ctx) -> Failure $ parserFailure pprefs pinfo err ctx+  where+    pinfo' = pinfo+      { infoParser = (Left <$> bashCompletionParser pinfo pprefs)+                 <|> (Right <$> infoParser pinfo) }+    p = runParserInfo pinfo' args++-- | Generate a `ParserFailure` from a `ParseError` in a given `Context`.+--+-- This function can be used, for example, to show the help text for a parser:+--+-- @handleParseResult . Failure $ parserFailure pprefs pinfo ShowHelpText mempty@+parserFailure :: ParserPrefs -> ParserInfo a+              -> ParseError -> [Context]+              -> ParserFailure ParserHelp+parserFailure pprefs pinfo msg ctx = ParserFailure $ \progn ->+  let h = with_context ctx pinfo $ \names pinfo' -> mconcat+            [ base_help pinfo'+            , usage_help progn names pinfo'+            , suggestion_help+            , error_help ]+  in (h, exit_code, prefColumns pprefs)+  where+    exit_code = case msg of+      ErrorMsg {}        -> ExitFailure (infoFailureCode pinfo)+      UnknownError       -> ExitFailure (infoFailureCode pinfo)+      MissingError {}    -> ExitFailure (infoFailureCode pinfo)+      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++    usage_help progn names i = case msg of+      InfoMsg _+        -> mempty+      _+        -> usageHelp $ vcatChunks+          [ pure . parserUsage pprefs (infoParser i) . unwords $ progn : names+          , fmap (indent 2) . infoProgDesc $ i ]++    error_help = errorHelp $ case msg of+      ShowHelpText+        -> mempty++      ErrorMsg m+        -> stringChunk m++      InfoMsg  m+        -> stringChunk m++      MissingError CmdStart _+        | prefShowHelpOnEmpty pprefs+        -> mempty++      MissingError _ (SomeParser x)+        -> stringChunk "Missing:" <<+>> missingDesc pprefs x++      ExpectsArgError x+        -> stringChunk $ "The option `" ++ x ++ "` expects an argument."++      UnexpectedError arg _+        -> stringChunk msg'+          where+            --+            -- This gives us the same error we have always+            -- reported+            msg' = case arg of+              ('-':_) -> "Invalid option `" ++ arg ++ "'"+              _       -> "Invalid argument `" ++ arg ++ "'"++      UnknownError+        -> mempty+++    suggestion_help = suggestionsHelp $ case msg of+      UnexpectedError arg (SomeParser x)+        --+        -- We have an unexpected argument and the parser which+        -- it's running over.+        --+        -- We can make a good help suggestion here if we do+        -- a levenstein distance between all possible suggestions+        -- and the supplied option or argument.+        -> suggestions+          where+            --+            -- Not using chunked here, as we don't want to+            -- show "Did you mean" if there's nothing there+            -- to show+            suggestions = (.$.) <$> prose+                                <*> (indent 4 <$> (vcatChunks . fmap stringChunk $ good ))++            --+            -- We won't worry about the 0 case, it won't be+            -- shown anyway.+            prose       = if length good < 2+                            then stringChunk "Did you mean this?"+                            else stringChunk "Did you mean one of these?"+            --+            -- Suggestions we will show, they're close enough+            -- to what the user wrote+            good        = filter isClose possibles++            --+            -- Bit of an arbitrary decision here.+            -- Edit distances of 1 or 2 will give hints+            isClose a   = editDistance a arg < 3++            --+            -- Similar to how bash completion works.+            -- We map over the parser and get the names+            -- ( no IO here though, unlike for completers )+            possibles   = concat $ mapParser opt_completions x++            --+            -- Look at the option and give back the possible+            -- things the user could type. If it's a command+            -- reader also ensure that it can be immediately+            -- reachable from where the error was given.+            opt_completions hinfo opt = case optMain opt of+              OptReader ns _ _ -> fmap showOption ns+              FlagReader ns _  -> fmap showOption ns+              ArgReader _      -> []+              CmdReader _ ns _  | hinfoUnreachableArgs hinfo+                               -> []+                                | otherwise+                               -> ns+      _+        -> mempty++    base_help :: ParserInfo a -> ParserHelp+    base_help i+      | show_full_help+      = 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,143 @@+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.List.NonEmpty (NonEmpty(..))+import Data.Maybe+import Data.Semigroup+import Prelude++import Options.Applicative.Help.Pretty++mappendWith :: Monoid a => a -> a -> a -> a+mappendWith s x y = mconcat [x, s, y]++-- | The free monoid on a semigroup 'a'.+newtype Chunk a = Chunk+  { unChunk :: Maybe a }+  deriving (Eq, Show)++instance Functor Chunk where+  fmap f = Chunk . fmap f . unChunk++instance Applicative Chunk where+  pure = Chunk . pure+  Chunk f <*> Chunk x = Chunk (f <*> x)++instance Alternative Chunk where+  empty = Chunk Control.Applicative.empty+  a <|> b = Chunk $ unChunk a <|> unChunk b++instance Monad Chunk where+  return = pure+  m >>= f = Chunk $ unChunk m >>= unChunk . f++instance 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 (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
+ src/Options/Applicative/Help/Core.hs view
@@ -0,0 +1,213 @@+module Options.Applicative.Help.Core (+  cmdDesc,+  briefDesc,+  missingDesc,+  fullDesc,+  ParserHelp(..),+  errorHelp,+  headerHelp,+  suggestionsHelp,+  usageHelp,+  bodyHelp,+  footerHelp,+  parserHelp,+  parserUsage,+  ) where++import Control.Applicative+import Control.Monad (guard)+import Data.Function (on)+import Data.List (sort, intersperse, groupBy)+import Data.Foldable (any)+import Data.Maybe (maybeToList, catMaybes, fromMaybe)+import Data.Monoid (mempty)+import Data.Semigroup (Semigroup (..))+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 }++safelast :: [a] -> Maybe a+safelast = foldl (const Just) Nothing++-- | Generate description for a single option.+optDesc :: ParserPrefs -> OptDescStyle -> OptHelpInfo -> Option a -> (Chunk Doc, Wrapping)+optDesc pprefs style info opt =+  let names+        = sort . optionNames . optMain $ opt+      meta+        = stringChunk $ optMetaVar opt+      descs+        = map (string . showOption) names+      descriptions+        = listToChunk (intersperse (descSep style) descs)+      desc+        | prefHelpLongEquals pprefs && not (isEmpty meta) && any isLongName (safelast names)+        = descriptions <> stringChunk "=" <> meta+        | otherwise+        = descriptions <<+>> meta+      show_opt+        | optVisibility opt == Hidden+        = descHidden style+        | otherwise+        = optVisibility opt == Visible+      suffix+        | hinfoMulti info+        = stringChunk . prefMultiSuffix $ pprefs+        | otherwise+        = mempty+      wrapping+        = wrapIf (length names > 1)+      rendered+        | not show_opt+        = mempty+        | otherwise+        = desc <> suffix+      modified+        = maybe id fmap (optDescMod opt) rendered+  in  (modified, wrapping)++-- | Generate descriptions for commands.+cmdDesc :: Parser a -> [(Maybe String, Chunk Doc)]+cmdDesc = mapParser desc+  where+    desc _ opt =+      case optMain opt of+        CmdReader gn cmds p -> (,) gn $+          tabulate [(string cmd, align (extractChunk d))+                   | cmd <- reverse cmds+                   , d <- maybeToList . fmap infoProgDesc $ p cmd ]+        _ -> mempty++-- | Generate a brief help text for a parser.+briefDesc :: ParserPrefs -> Parser a -> Chunk Doc+briefDesc = briefDesc' True++-- | Generate a brief help text for a parser, only including mandatory+--   options and arguments.+missingDesc :: ParserPrefs -> Parser a -> Chunk Doc+missingDesc = briefDesc' False++-- | Generate a brief help text for a parser, allowing the specification+--   of if optional arguments are show.+briefDesc' :: Bool -> ParserPrefs -> Parser a -> Chunk Doc+briefDesc' showOptional pprefs+    = wrap NoDefault . foldTree . mfilterOptional . treeMapParser (optDesc pprefs style)+  where+    mfilterOptional+      | showOptional+      = id+      | otherwise+      = filterOptional++    style = OptDescStyle+      { descSep = string "|"+      , descHidden = False }++-- | Wrap a doc in parentheses or brackets if required.+wrap :: AltNodeType ->  (Chunk Doc, Wrapping) -> Chunk Doc+wrap altnode (chunk, wrapping)+  | altnode == MarkDefault+  = fmap brackets chunk+  | needsWrapping wrapping+  = fmap parens chunk+  | otherwise+  = chunk++-- Fold a tree of option docs into a single doc with fully marked+-- optional areas and groups.+foldTree :: OptTree (Chunk Doc, Wrapping) -> (Chunk Doc, Wrapping)+foldTree (Leaf x)+  = x+foldTree (MultNode xs)+  = (foldr ((<</>>) . wrap NoDefault . foldTree) mempty xs, Bare)+foldTree (AltNode b xs)+  = (\x -> (x, Bare))+  . wrap b+  . alt_node+  . filter (not . isEmpty . fst)+  . map foldTree $ xs+    where+  alt_node :: [(Chunk Doc, Wrapping)] -> (Chunk Doc, Wrapping)+  alt_node [n] = n+  alt_node ns = (\y -> (y, Wrapped))+              . foldr (chunked (\x y -> x </> char '|' </> y) . wrap NoDefault) 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 = fst $ 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 }++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 }++usageHelp :: Chunk Doc -> ParserHelp+usageHelp chunk = mempty { helpUsage = 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+  $ with_title "Available options:" (fullDesc pprefs p)+  : (group_title <$> cs)+  where+    def = "Available commands:"++    cs = groupBy ((==) `on` fst) $ cmdDesc p++    group_title a@((n,_):_) = with_title (fromMaybe def n) $+      vcatChunks (snd <$> a)+    group_title _ = mempty+++    with_title :: String -> Chunk Doc -> Chunk Doc+    with_title title = fmap (string title .$.)++-- | Generate option summary.+parserUsage :: ParserPrefs -> Parser a -> String -> Doc+parserUsage pprefs p progn = hsep+  [ string "Usage:"+  , string progn+  , align (extractChunk (briefDesc pprefs p)) ]++data Wrapping+  = Bare+  | Wrapped+  deriving (Eq, Show)++wrapIf :: Bool -> Wrapping+wrapIf b = if b then Wrapped else Bare++needsWrapping :: Wrapping -> Bool+needsWrapping = (==) Wrapped
+ src/Options/Applicative/Help/Levenshtein.hs view
@@ -0,0 +1,61 @@+module Options.Applicative.Help.Levenshtein (+    editDistance+  ) where++-- | Calculate the Damerau-Levenshtein edit distance+--   between two lists (strings).+--+--   This is modified from+--   https://wiki.haskell.org/Edit_distance+--   and is originally from Lloyd Allison's paper+--   "Lazy Dynamic-Programming can be Eager"+--+--   It's been changed though from Levenshtein to+--   Damerau-Levenshtein, which treats transposition+--   of adjacent characters as one change instead of+--   two.+editDistance :: Eq a => [a] -> [a] -> Int+editDistance a b = last $+  case () of+    _ | lab == 0+     -> mainDiag+      | lab > 0+     -> lowers !! (lab - 1)+      | otherwise+     -> uppers !! (-1 - lab)+  where+    mainDiag = oneDiag a b (head uppers) (-1 : head lowers)+    uppers = eachDiag a b (mainDiag : uppers) -- upper diagonals+    lowers = eachDiag b a (mainDiag : lowers) -- lower diagonals+    eachDiag _ [] _ = []+    eachDiag _ _ [] = []+    eachDiag a' (_:bs) (lastDiag:diags) =+      oneDiag a' bs nextDiag lastDiag : eachDiag a' bs diags+      where+        nextDiag = head (tail diags)+    oneDiag a' b' diagAbove diagBelow = thisdiag+      where+        doDiag [] _ _ _ _ = []+        doDiag _ [] _ _ _ = []+        -- Check for a transposition+        -- We don't add anything to nw here, the next character+        -- will be different however and the transposition+        -- will have an edit distance of 1.+        doDiag (ach:ach':as) (bch:bch':bs) nw n w+          | ach' == bch && ach == bch'+          = nw : doDiag (ach' : as) (bch' : bs) nw (tail n) (tail w)+        -- Standard case+        doDiag (ach:as) (bch:bs) nw n w =+          me : doDiag as bs me (tail n) (tail w)+          where+            me =+              if ach == bch+                then nw+                else 1 + min3 (head w) nw (head n)+        firstelt = 1 + head diagBelow+        thisdiag = firstelt : doDiag a' b' firstelt diagAbove (tail diagBelow)+    lab = length a - length b+    min3 x y z =+      if x < y+        then x+        else min y z
+ src/Options/Applicative/Help/Pretty.hs view
@@ -0,0 +1,10 @@+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.<$>)
+ src/Options/Applicative/Help/Types.hs view
@@ -0,0 +1,41 @@+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+  , 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 mempty+  mappend = (<>)++instance Semigroup ParserHelp where+  (ParserHelp e1 s1 h1 u1 b1 f1) <> (ParserHelp e2 s2 h2 u2 b2 f2)+    = ParserHelp (mappend e1 e2) (mappend s1 s2)+                 (mappend h1 h2) (mappend u1 u2)+                 (mappend b1 b2) (mappend f1 f2)++helpText :: ParserHelp -> Doc+helpText (ParserHelp e s h u b f) = extractChunk . vsepChunks $ [e, s, h, u, b, f]++-- | Convert a help text to 'String'.+renderHelp :: Int -> ParserHelp -> String+renderHelp cols+  = (`displayS` "")+  . renderPretty 1.0 cols+  . helpText
+ src/Options/Applicative/Internal.hs view
@@ -0,0 +1,265 @@+module Options.Applicative.Internal+  ( P+  , MonadP(..)+  , ParseError(..)++  , uncons+  , hoistMaybe+  , hoistEither+  , runReadM+  , withReadM++  , runP++  , Completion+  , runCompletion+  , contextNames++  , ListT+  , takeListT+  , runListT++  , NondetT+  , cut+  , (<!>)+  , disamb+  ) where++import Control.Applicative+import Prelude+import Control.Monad (MonadPlus(..), liftM, ap, guard)+import Control.Monad.Trans.Class (MonadTrans, lift)+import Control.Monad.Trans.Except+  (runExcept, runExceptT, withExcept, ExceptT(..), throwE)+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)++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
+ src/Options/Applicative/Types.hs view
@@ -0,0 +1,436 @@+{-# LANGUAGE CPP, Rank2Types, ExistentialQuantification #-}+module Options.Applicative.Types (+  ParseError(..),+  ParserInfo(..),+  ParserPrefs(..),++  Option(..),+  OptName(..),+  isShortName,+  isLongName,++  OptReader(..),+  OptProperties(..),+  OptVisibility(..),+  Backtracking(..),+  ReadM(..),+  readerAsk,+  readerAbort,+  readerError,+  CReader(..),+  Parser(..),+  ParserM(..),+  Completer(..),+  mkCompleter,+  CompletionResult(..),+  ParserFailure(..),+  ParserResult(..),+  overFailure,+  Args,+  ArgPolicy(..),+  OptHelpInfo(..),+  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+  | 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)+  } 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)++-- | 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+  , propDescMod :: Maybe ( Doc -> Doc )   -- ^ a function to run over the brief description+  }++instance Show OptProperties where+  showsPrec p (OptProperties pV pH pMV pSD _)+    = showParen (p >= 11)+    $ showString "OptProperties { propVisibility = " . shows pV+    . showString ", propHelp = " . shows pH+    . showString ", propMetaVar = " . shows pMV+    . showString ", propShowDefault = " . shows pSD+    . showString ", propDescMod = _ }"++-- | A single option of a parser.+data Option a = Option+  { optMain :: OptReader a               -- ^ reader for this option+  , optProps :: OptProperties            -- ^ properties of this option+  }++data SomeParser = forall a . SomeParser (Parser a)++-- | Subparser context, containing the 'name' of the subparser, and its parser info.+--   Used by parserFailure to display relevant usage information when parsing inside a subparser fails.+data Context = forall a . Context String (ParserInfo a)++instance Show (Option a) where+    show opt = "Option {optProps = " ++ show (optProps opt) ++ "}"++instance Functor Option where+  fmap f (Option m p) = Option (fmap f m) p++-- | A newtype over 'ReaderT String Except', used by option readers.+newtype ReadM a = ReadM+  { unReadM :: ReaderT String (Except ParseError) a }++instance Functor ReadM where+  fmap f (ReadM r) = ReadM (fmap f r)++instance Applicative ReadM where+  pure = ReadM . pure+  ReadM x <*> ReadM y = ReadM $ x <*> y++instance Alternative ReadM where+  empty = mzero+  (<|>) = mplus++instance Monad ReadM where+  return = pure+  ReadM r >>= f = ReadM $ r >>= unReadM . f++#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] (String -> Maybe (ParserInfo a))+  -- ^ command reader++instance Functor OptReader where+  fmap f (OptReader ns cr e) = OptReader ns (fmap f cr) e+  fmap f (FlagReader ns x) = FlagReader ns (f x)+  fmap f (ArgReader cr) = ArgReader (fmap f cr)+  fmap f (CmdReader n cs g) = CmdReader n cs ((fmap . fmap) f . g)++-- | A @Parser a@ is an option parser returning a value of type 'a'.+data Parser a+  = NilP (Maybe a)+  | OptP (Option a)+  | forall x . MultP (Parser (x -> a)) (Parser x)+  | AltP (Parser a) (Parser a)+  | forall x . BindP (Parser x) (x -> Parser a)++instance Functor Parser where+  fmap f (NilP x) = NilP (fmap f x)+  fmap f (OptP opt) = OptP (fmap f opt)+  fmap f (MultP p1 p2) = MultP (fmap (f.) p1) p2+  fmap f (AltP p1 p2) = AltP (fmap f p1) (fmap f p2)+  fmap f (BindP p k) = BindP p (fmap f . k)++instance Applicative Parser where+  pure = NilP . Just+  (<*>) = MultP++newtype ParserM r = ParserM+  { runParserM :: forall x . (r -> Parser x) -> Parser x }++instance Monad ParserM where+  return = 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 p = fromM $ manyM p+  some p = fromM $ (:) <$> oneM p <*> manyM p++-- | A shell complete function.+newtype Completer = Completer+  { runCompleter :: String -> IO [String] }++-- | Smart constructor for a 'Completer'+mkCompleter :: (String -> IO [String]) -> Completer+mkCompleter = Completer++instance Semigroup Completer where+  (Completer c1) <> (Completer c2) =+    Completer $ \s -> (++) <$> c1 s <*> c2 s++instance Monoid Completer where+  mempty = Completer $ \_ -> return []+  mappend = (<>)++newtype CompletionResult = CompletionResult+  { execCompletion :: String -> IO String }++instance Show CompletionResult where+  showsPrec p _ = showParen (p > 10) $+    showString "CompletionResult _"++newtype ParserFailure h = ParserFailure+  { execFailure :: String -> (h, ExitCode, Int) }++instance Show h => Show (ParserFailure h) where+  showsPrec p (ParserFailure f)+    = showParen (p > 10)+    $ showString "ParserFailure "+    . showsPrec 11 (f "<program>")++instance Functor ParserFailure where+  fmap f (ParserFailure err) = ParserFailure $ \progn ->+    let (h, exit, cols) = err progn in (f h, exit, cols)++-- | Result of 'execParserPure'.+data ParserResult a+  = Success a+  | Failure (ParserFailure ParserHelp)+  | CompletionInvoked CompletionResult+  deriving Show++instance Functor ParserResult where+  fmap f (Success a) = Success (f a)+  fmap _ (Failure f) = Failure f+  fmap _ (CompletionInvoked c) = CompletionInvoked c++overFailure :: (ParserHelp -> ParserHelp)+            -> ParserResult a -> ParserResult a+overFailure f (Failure failure) = Failure $ fmap f failure+overFailure _ r = r++instance Applicative ParserResult where+  pure = Success+  Success f <*> r = fmap f r+  Failure f <*> _ = Failure f+  CompletionInvoked c <*> _ = CompletionInvoked c++instance Monad ParserResult where+  return = pure+  Success x >>= f = f x+  Failure f >>= _ = Failure f+  CompletionInvoked c >>= _ = CompletionInvoked c++type Args = [String]++-- | Policy for how to handle options within the parse+data ArgPolicy+  = Intersperse+  -- ^ The default policy, options and arguments can+  --   be interspersed.+  --   A `--` option can be passed to ensure all following+  --   commands are treated as arguments.+  | NoIntersperse+  -- ^ Options must all come before arguments, once a+  --   single positional argument or subcommand is parsed,+  --   all remaining arguments are treated as positionals.+  --   A `--` option can be passed if the first positional+  --   one needs starts with `-`.+  | AllPositionals+  -- ^ No options are parsed at all, all arguments are+  --   treated as positionals.+  --   Is the policy used after `--` is encountered.+  | ForwardOptions+  -- ^ Options and arguments can be interspersed, but if+  --   a given option is not found, it is treated as a+  --   positional argument. This is sometimes useful if+  --   one is passing through most options to another tool,+  --   but are supplying just a few of their own options.+  deriving (Eq, Ord, Show)++data OptHelpInfo = OptHelpInfo+  { hinfoMulti :: Bool           -- ^ Whether this is part of a many or some (approximately)+  , hinfoUnreachableArgs :: 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]+  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)++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/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/test.hs view
@@ -13,6 +13,7 @@ import           Control.Applicative import           Control.Monad import           Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as BS8 import           Data.List hiding (group) import           Data.Semigroup hiding (option) import           Data.String@@ -146,6 +147,98 @@       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@@ -393,6 +486,16 @@       result = execParserPure (prefs noBacktrack) i ["c", "-b"]   in assertError result $ \_ -> property succeeded +prop_subparser_inline :: Property+prop_subparser_inline = once $+  let p2 = switch (short 'a')+      p1 = (,)+        <$> subparser (command "c" (info p2 idm))+        <*> switch (short 'b')+      i = info (p1 <**> helper) idm+      result = execParserPure (prefs subparserInline) i ["c", "-b", "-a" ]+  in assertResult result ((True, True) ===)+ prop_error_context :: Property prop_error_context = once $   let p = pk <$> option auto (long "port")@@ -667,7 +770,7 @@       p = argument str idm       i = info p idm       result = run i ["testValue"]-  in assertResult result $ \xs -> fromString t === xs+  in assertResult result $ \xs -> BS8.pack t === xs  --- @@ -732,7 +835,7 @@  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+  editDistance (as ++ [a,b] ++ bs) (as ++ [b,a] ++ bs) === 1  ---