optparse-applicative 0.15.1.0 → 0.19.0.0
raw patch · 37 files changed
Files
- CHANGELOG.md +122/−0
- README.md +94/−27
- optparse-applicative.cabal +58/−26
- src/Options/Applicative.hs +13/−6
- src/Options/Applicative/BashCompletion.hs +45/−37
- src/Options/Applicative/Builder.hs +103/−18
- src/Options/Applicative/Builder/Completer.hs +10/−0
- src/Options/Applicative/Builder/Internal.hs +17/−5
- src/Options/Applicative/Common.hs +58/−41
- src/Options/Applicative/Extra.hs +97/−41
- src/Options/Applicative/Help/Chunk.hs +9/−15
- src/Options/Applicative/Help/Core.hs +385/−114
- src/Options/Applicative/Help/Levenshtein.hs +45/−27
- src/Options/Applicative/Help/Pretty.hs +85/−18
- src/Options/Applicative/Help/Types.hs +12/−7
- src/Options/Applicative/Internal.hs +25/−4
- src/Options/Applicative/NonEmpty.hs +16/−0
- src/Options/Applicative/Types.hs +41/−18
- tests/Examples/Cabal.hs +2/−6
- tests/Examples/LongSub.hs +34/−0
- tests/Examples/ParserGroup/AllGrouped.hs +91/−0
- tests/Examples/ParserGroup/Basic.hs +111/−0
- tests/Examples/ParserGroup/CommandGroups.hs +134/−0
- tests/Examples/ParserGroup/DuplicateCommandGroups.hs +92/−0
- tests/Examples/ParserGroup/Duplicates.hs +153/−0
- tests/Examples/ParserGroup/Nested.hs +139/−0
- tests/cabal.err.txt +5/−0
- tests/formatting-long-subcommand.err.txt +9/−0
- tests/formatting.err.txt +1/−0
- tests/hello.err.txt +1/−0
- tests/parser_group_all_grouped.err.txt +16/−0
- tests/parser_group_basic.err.txt +21/−0
- tests/parser_group_command_groups.err.txt +33/−0
- tests/parser_group_duplicate_command_groups.err.txt +24/−0
- tests/parser_group_duplicates.err.txt +24/−0
- tests/parser_group_nested.err.txt +37/−0
- tests/test.hs +222/−18
CHANGELOG.md view
@@ -1,3 +1,125 @@+## Version 0.19.0.0 (03 June 2025)++- Add `briefHangPoint` modifier. This allows one to specify the command length+ after which the rendering will change from aligned with the end of the+ command name to being indented on the next line.++- Add `parserOptionGroup` for grouping Options together, similar to command+ groups. Requires the breaking change of adding the `propGroup :: OptGroup`+ field to `OptProperties`.+++## Version 0.18.1.0 (29 May 2023)++- Change pretty printer layout algorithm used.++ The layoutSmart algorithm appears to be extremely slow with some command line+ sets, to the point where the program appears to hang.++ Fixes issues:+ * \# 476 - Stack executable 'hangs' with 0.17.1 and 0.18.0.++- Render help text with `AnsiStyle` aware rendering functions.++## Version 0.18.0.0 (22 May 2023)++- Move to 'prettyprinter` library for pretty printing.++ This is a potentially breaking change when one uses the '*Doc' family of functions+ (like `headerDoc`) from `Options.Applicative`. However, as versions of+ 'ansi-wl-pprint > 1.0' export a compatible `Doc` type, this can be mitigated by+ using a recent version.++ One can also either import directly from `Options.Applicative.Help` or from the+ `Prettyprinter` module of 'prettyprinter'.++- Allow commands to be disambiguated in a similar manner to flags when the+ `disambiguate` modifier is used.++ This is a potentially breaking change as the internal `CmdReader` constructor+ has been adapted so it is able to be inspected to a greater degree to support+ finding prefix matches.++## Version 0.17.1.0 (22 May 2023)++- Widen bounds for `ansi-wl-pprint`. This supports the use of `prettyprinter`+ in a non-breaking way, as the `ansi-wl-pprint > 1.0` support the newer+ library.++- Export `helpIndent` from `Options.Applicative`.++- Export completion script generators from `Options.Applicative.BashCompletion`.++- Add `simpleVersioner` utility for adding a '--version' option to a parser.++- Improve documentation.++- Drop support for GHC 7.0 and 7.2.++## Version 0.17.0.0 (1 Feb 2022)++- Make tabulation width configurable in usage texts.++- Separate program name and description in ParserHelp type.++- Add `helperWith` function, which can be easily used to+ localize the help flag.++- Improve usage texts when command names are long.++- Improve Documentation.++## Version 0.16.1.0 (21 Nov 2020)++- Guard `process` dependency behind an on by default flag.+ This allows one to shrink the dependency tree significantly+ by turning off the ability to use bash completion actions.++- Remove `bytestring` dependency from the test suite.++## Version 0.16.0.0 (14 Aug 2020)++- Add `Options.Applicative.NonEmpty.some1` function, which+ parses options the same as `some1` from base, but doesn't+ cause duplicates in the usage texts.++- Further improve help text generation in the presence+ of optional values when nesting is involved, and many and+ some when displayed with a suffix.++- Add "global" options to the usage texts for subcommands.+ When using subcommands, a "global options" section can+ now appear below the options and commands sections.++ Global options are *off* by default, to enable them, use+ the `helpShowGlobals` modifier.++ The `noGlobal` builder will suppress a single option being+ displayed in the global options list.++ Fixes issues:+ * \# 175 - List detailed subparser documentation with `--help`+ * \# 294 - Displaying global options when listing options for a command.+ * \# 359 - Subcommand help text lacks required parent command arguments++- Allow the `--help` option to take the name of a command.+ Usage without any arguments is the same, but now, when an+ argument is given, if it is the name of a currently+ reachable command, the help text for that command will+ be show.++ Fixes issues:+ * \# 379 - cmd --help subcmd is not the same as cmd subcmd --help++- Updated dependency bounds.++- Add builder for the all positional parser policy.++- Remove deprecated functions+ * nullOption+ * execParserMaybe+ * customExecParserMaybe+ ## Version 0.15.1.0 (12 Sep 2019) - Improve printing of brief descriptions for parsers.
README.md view
@@ -4,6 +4,7 @@ [![Hackage page (downloads and API reference)][hackage-png]][hackage] [![Hackage-Deps][hackage-deps-png]][hackage-deps] + optparse-applicative is a haskell library for parsing options on the command line, and providing a powerful [applicative] interface for composing them.@@ -42,6 +43,7 @@ - [Applicative Do](#applicative-do) - [FAQ](#faq) - [How it works](#how-it-works)+- [Tutorials](#tutorials) ## Introduction @@ -73,7 +75,6 @@ ```haskell import Options.Applicative-import Data.Semigroup ((<>)) data Sample = Sample { hello :: String@@ -301,8 +302,15 @@ parsers are also able to be composed with standard combinators. For example: `optional :: Alternative f => f a -> f (Maybe a)` will mean the user is not required to provide input for the affected-`Parser`.+`Parser`. For example, the following parser will return `Nothing`+instead of failing if the user doesn't supply an `output` option: +```haskell+optional $ strOption+ ( long "output"+ <> metavar "DIRECTORY" )+```+ ### Running parsers Before we can run a `Parser`, we need to wrap it into a `ParserInfo`@@ -502,7 +510,7 @@ `many` or `some` combinator: ```haskell-some (argument str (metavar "FILES..."))+some (argument str (metavar "FILES")) ``` Note that arguments starting with `-` are considered options by@@ -525,22 +533,6 @@ global options that apply to all of them. Typical examples are version control systems like `git`, or build tools like `cabal`. -A command can be created using the `subparser` builder (or `hsubparser`,-which is identical but for an additional `--help` option on each-command), and commands can be added with the `command` modifier.-For example--```haskell-subparser- ( command "add" (info addOptions ( progDesc "Add a file to the repository" ))- <> command "commit" (info commitOptions ( progDesc "Record changes to the repository" ))- )-```--Each command takes a full `ParserInfo` structure, which will be-used to extract a description for this command when generating a-help text.- Note that all the parsers appearing in a command need to have the same type. For this reason, it is often best to use a sum type which has the same structure as the command itself. For example,@@ -557,6 +549,22 @@ ... ``` +A command can then be created using the `subparser` builder (or+`hsubparser`, which is identical but for an additional `--help` option+on each command), and commands can be added with the `command`+modifier. For example,++```haskell+hsubparser+ ( command "add" (info addCommand ( progDesc "Add a file to the repository" ))+ <> command "commit" (info commitCommand ( progDesc "Record changes to the repository" ))+ )+```++Each command takes a full `ParserInfo` structure, which will be+used to extract a description for this command when generating a+help text.+ Alternatively, you can directly return an `IO` action from a parser, and execute it using `join` from `Control.Monad`. @@ -565,7 +573,7 @@ stop :: IO () opts :: Parser (IO ())-opts = subparser+opts = hsubparser ( command "start" (info (start <$> argument str idm) idm) <> command "stop" (info (pure stop) idm) ) @@ -700,6 +708,11 @@ ``` +**Note**. If an option name is a prefix of another option, then it+will never be matched when disambiguation is on. See+[#419](https://github.com/pcapriotti/optparse-applicative/issues/419)+for more details.+ ### Customising the help screen optparse-applicative has a number of combinators to help customise@@ -709,8 +722,8 @@ specify a brief description or tagline for the program, and detailed information surrounding the generated option and command descriptions. -Internally we actually use the [ansi-wl-pprint][ansi-wl-pprint]-library, and one can use the `headerDoc` combinator and friends if+Internally we actually use the [prettyprinter][prettyprinter]+library, and one can supply either text or prettyprinter `Doc` elements if additional customisation is required. To display the usage text, the user may type `--help` if the `helper`@@ -736,6 +749,52 @@ p = prefs showHelpOnEmpty ``` +#### Option groups++The `parserOptionGroup` function can be used to group options together under+a common heading. For example, if we have:++```haskell+Args+ <$> parseMain+ <*> parserOptionGroup "Group A" parseA+ <*> parserOptionGroup "Group B" parseB+ <*> parseOther+```++Then the `--help` page `Available options` will look like:++```+Available options:+ <main options>+ <other options>++Group A+ <A options>++Group B+ <B options>+```++Caveats:++- Parser groups are like command groups in that groups are listed in creation+ order, and duplicate groups are consolidated.++- Nested groups are indented:++ ```haskell+ parserOptionGroup "Group Outer" (parserOptionGroup "Group Inner" parseA)+ ```++ Will render as:++ ```+ Group Outer+ - Group Inner+ ...+ ```+ ### Command groups One experimental feature which may be useful for programs with many@@ -751,11 +810,11 @@ hello = Hello <$> many (argument str (metavar "TARGET...")) sample :: Parser Sample-sample = subparser+sample = hsubparser ( command "hello" (info hello (progDesc "Print greeting")) <> command "goodbye" (info (pure Goodbye) (progDesc "Say goodbye")) )- <|> subparser+ <|> hsubparser ( command "bonjour" (info hello (progDesc "Print greeting")) <> command "au-revoir" (info (pure Goodbye) (progDesc "Say goodbye")) <> commandGroup "French commands:"@@ -1003,6 +1062,14 @@ See [this blog post][blog] for a more detailed explanation based on a simplified implementation. +## Tutorials++These are some tutorials found on the web:++- [A Gentle Introduction to optparse-applicative](https://prborges.com/2023/introduction-to-optparse-applicative/).+- [optparse-applicative quick start](https://ro-che.info/articles/2016-12-30-optparse-applicative-quick-start).+- [Applicative Options Parsing in Haskell](https://thoughtbot.com/blog/applicative-options-parsing-in-haskell).+ [aeson]: http://hackage.haskell.org/package/aeson [applicative]: http://hackage.haskell.org/package/base/docs/Control-Applicative.html [arrows]: http://www.haskell.org/arrows/syntax.html@@ -1016,6 +1083,6 @@ [monoid]: http://hackage.haskell.org/package/base/docs/Data-Monoid.html [semigroup]: http://hackage.haskell.org/package/base/docs/Data-Semigroup.html [parsec]: http://hackage.haskell.org/package/parsec- [status]: http://travis-ci.org/pcapriotti/optparse-applicative?branch=master- [status-png]: https://api.travis-ci.org/pcapriotti/optparse-applicative.svg?branch=master- [ansi-wl-pprint]: http://hackage.haskell.org/package/ansi-wl-pprint+ [status]: https://github.com/pcapriotti/optparse-applicative/actions/workflows/haskell-ci.yml+ [status-png]: https://github.com/pcapriotti/optparse-applicative/workflows/Haskell-CI/badge.svg+ [prettyprinter]: http://hackage.haskell.org/package/prettyprinter
optparse-applicative.cabal view
@@ -1,15 +1,15 @@ name: optparse-applicative-version: 0.15.1.0+version: 0.19.0.0 synopsis: Utilities and combinators for parsing command line options description: optparse-applicative is a haskell library for parsing options- on the command line, providing a powerful applicative interface- for composing these options.+ on the command line, and providing a powerful applicative+ interface for composing them. . optparse-applicative takes care of reading and validating the arguments passed to the command line, handling and reporting errors, generating a usage line, a comprehensive help screen,- and enabling context-sensitive bash completions.+ and enabling context-sensitive bash, zsh, and fish completions. . See the included README for detailed instructions and examples, which is also available on github@@ -21,7 +21,7 @@ copyright: (c) 2012-2017 Paolo Capriotti <paolo@capriotti.io> category: System, CLI, Options, Parsing build-type: Simple-cabal-version: >= 1.8+cabal-version: >= 1.10 extra-source-files: CHANGELOG.md README.md tests/alt.err.txt@@ -36,33 +36,54 @@ tests/helponemptysub.err.txt tests/long_equals.err.txt tests/formatting.err.txt+ tests/formatting-long-subcommand.err.txt tests/nested.err.txt tests/optional.err.txt+ tests/parser_group_all_grouped.err.txt+ tests/parser_group_basic.err.txt+ tests/parser_group_command_groups.err.txt+ tests/parser_group_duplicate_command_groups.err.txt+ tests/parser_group_duplicates.err.txt+ tests/parser_group_nested.err.txt tests/nested_optional.err.txt tests/subparsers.err.txt homepage: https://github.com/pcapriotti/optparse-applicative bug-reports: https://github.com/pcapriotti/optparse-applicative/issues tested-with:- GHC==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+ GHC==9.12.1+ GHC==9.10.1+ GHC==9.8.4+ GHC==9.6.1+ GHC==9.4.4+ GHC==9.2.7+ GHC==9.0.2+ GHC==8.10.7+ GHC==8.8.4+ GHC==8.6.5+ GHC==8.4.4+ GHC==8.2.2+ GHC==8.0.2+ GHC==7.10.3+ GHC==7.8.4+ GHC==7.6.3+ GHC==7.4.2+ GHC==7.2.2+ GHC==7.0.4 source-repository head type: git location: https://github.com/pcapriotti/optparse-applicative.git +flag process+ description:+ Depend on the process package for Bash autocompletion+ default: True+ library hs-source-dirs: src ghc-options: -Wall+ default-language: Haskell98 -- See https://ghc.haskell.org/trac/ghc/wiki/Migration/8.0#base-4.9.0.0 if impl(ghc >= 8.0)@@ -84,17 +105,21 @@ , Options.Applicative.Help.Levenshtein , Options.Applicative.Help.Pretty , Options.Applicative.Help.Types+ , Options.Applicative.NonEmpty , Options.Applicative.Types , Options.Applicative.Internal - build-depends: base == 4.*- , transformers >= 0.2 && < 0.6- , transformers-compat >= 0.3 && < 0.7- , process >= 1.0 && < 1.7- , ansi-wl-pprint >= 0.6.8 && < 0.7+ build-depends: base >= 4.5 && < 5+ , text >= 1.2+ , transformers >= 0.5 && < 0.7+ , prettyprinter >= 1.7 && < 1.8+ , prettyprinter-ansi-terminal >= 1.1.2 && < 1.2 + if flag(process)+ build-depends: process >= 1.0 && < 1.7+ if !impl(ghc >= 8)- build-depends: semigroups >= 0.10 && < 0.20+ build-depends: semigroups >= 0.10 && < 0.21 , fail == 4.9.* test-suite tests@@ -104,19 +129,26 @@ ghc-options: -Wall -threaded -O2 -funbox-strict-fields - hs-source-dirs:- tests+ hs-source-dirs: tests + default-language: Haskell98+ other-modules: Examples.Alternatives , Examples.Cabal , Examples.Commands , Examples.Formatting , Examples.Hello+ , Examples.LongSub+ , Examples.ParserGroup.AllGrouped+ , Examples.ParserGroup.Basic+ , Examples.ParserGroup.CommandGroups+ , Examples.ParserGroup.DuplicateCommandGroups+ , Examples.ParserGroup.Duplicates+ , Examples.ParserGroup.Nested build-depends: base- , bytestring >= 0.9 && < 0.11 , optparse-applicative- , QuickCheck >= 2.8 && < 2.14+ , QuickCheck >= 2.8 && < 2.16 if !impl(ghc >= 8) build-depends: semigroups
src/Options/Applicative.hs view
@@ -7,7 +7,7 @@ -- 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+ -- See the sections below for more detail. -- * Exported modules --@@ -18,7 +18,7 @@ -- -- | 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+ -- yield a value of type @a@ when the command line arguments are successfully -- parsed. -- -- There are several types of primitive 'Parser'.@@ -74,13 +74,14 @@ abortOption, infoOption, helper,+ simpleVersioner, -- ** Modifiers -- -- | 'Parser' builders take a modifier, which represents a modification of the -- properties of an option, and can be composed as a monoid. --- -- Contraints are often used to ensure that the modifiers can be sensibly applied.+ -- Constraints are often used to ensure that the modifiers can be sensibly applied. -- For example, positional arguments can't be specified by long or short names, -- so the 'HasName' constraint is used to ensure we have a flag or option. Mod,@@ -104,6 +105,7 @@ completer, idm, mappend,+ parserOptionGroup, OptionFields, FlagFields,@@ -114,18 +116,20 @@ 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'.+ -- including t'Data.ByteString.ByteString' and t'Data.Text.Text'; and 'auto',+ -- which uses the 'Read' typeclass, and is good for simple types like 'Int' or+ -- 'Double'. -- -- More complex types can use the 'eitherReader' or 'maybeReader' -- functions to pattern match or use a more expressive parser like a- -- member of the 'Parsec' family.+ -- member of the @Parsec@ family. ReadM, auto,@@ -196,6 +200,9 @@ subparserInline, columns, helpLongEquals,+ helpShowGlobals,+ helpIndent,+ briefHangPoint, defaultPrefs, -- * Completions
src/Options/Applicative/BashCompletion.hs view
@@ -4,7 +4,11 @@ -- <http://github.com/pcapriotti/optparse-applicative/wiki/Bash-Completion the wiki> -- for more information on bash completion. module Options.Applicative.BashCompletion- ( bashCompletionParser+ ( bashCompletionParser,++ bashCompletionScript,+ fishCompletionScript,+ zshCompletionScript, ) where import Control.Applicative@@ -34,11 +38,15 @@ bashCompletionParser :: ParserInfo a -> ParserPrefs -> Parser CompletionResult bashCompletionParser pinfo pprefs = complParser where- failure opts = CompletionResult- { execCompletion = \progn -> unlines <$> opts progn }+ returnCompletions opts =+ CompletionResult $+ \progn -> unlines <$> opts progn + scriptRequest =+ CompletionResult . fmap pure+ complParser = asum- [ failure <$>+ [ returnCompletions <$> ( bashCompletionQuery pinfo pprefs -- To get rich completions, one just needs the first -- command. To customise the lengths, use either of@@ -53,15 +61,13 @@ <*> (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))++ , scriptRequest . bashCompletionScript <$>+ strOption (long "bash-completion-script" `mappend` internal)+ , scriptRequest . fishCompletionScript <$>+ strOption (long "fish-completion-script" `mappend` internal)+ , scriptRequest . zshCompletionScript <$>+ strOption (long "zsh-completion-script" `mappend` internal) ] bashCompletionQuery :: ParserInfo a -> ParserPrefs -> Richness -> [String] -> Int -> String -> IO [String]@@ -91,7 +97,7 @@ -- -- For options and flags, ensure that the user -- hasn't disabled them with `--`.- opt_completions argPolicy hinfo opt = case optMain opt of+ opt_completions argPolicy reachability opt = case optMain opt of OptReader ns _ _ | argPolicy /= AllPositionals -> return . add_opt_help opt $ show_names ns@@ -103,15 +109,15 @@ | otherwise -> return [] ArgReader rdr- | hinfoUnreachableArgs hinfo+ | argumentIsUnreachable reachability -> return [] | otherwise -> run_completer (crCompleter rdr)- CmdReader _ ns p- | hinfoUnreachableArgs hinfo+ CmdReader _ ns+ | argumentIsUnreachable reachability -> return [] | otherwise- -> return . add_cmd_help p $ filter_names ns+ -> return . with_cmd_help $ filter (is_completion . fst) ns -- When doing enriched completions, add any help specified -- to the completion variables (tab separated).@@ -126,30 +132,28 @@ -- 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+ with_cmd_help :: Functor f => f (String, ParserInfo a) -> f String+ with_cmd_help =+ case richness of+ Standard ->+ fmap fst+ Enriched _ len ->+ fmap $ \(cmd, cmdInfo) ->+ let h = unChunk (infoProgDesc cmdInfo)+ in maybe cmd (\h' -> cmd ++ "\t" ++ render_line len h') h show_names :: [OptName] -> [String]- show_names = filter_names . map showOption+ show_names = filter is_completion . map showOption -- We only want to show a single line in the completion results description. -- If there was a line break, it would come across as a different completion -- possibility. render_line :: Int -> Doc -> String- render_line len doc = case lines (displayS (renderPretty 1 len doc) "") of+ render_line len doc = case lines (prettyString 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'')) @@ -161,8 +165,9 @@ w:_ -> isPrefixOf w _ -> const True -bashCompletionScript :: String -> String -> IO [String]-bashCompletionScript prog progn = return+-- | Generated bash shell completion script+bashCompletionScript :: String -> String -> String+bashCompletionScript prog progn = unlines [ "_" ++ progn ++ "()" , "{" , " local CMDLINE"@@ -196,8 +201,10 @@ Tab characters separate items from descriptions. -}-fishCompletionScript :: String -> String -> IO [String]-fishCompletionScript prog progn = return++-- | Generated fish shell completion script +fishCompletionScript :: String -> String -> String+fishCompletionScript prog progn = unlines [ " function _" ++ progn , " set -l cl (commandline --tokenize --current-process)" , " # Hack around fish issue #3934"@@ -219,8 +226,9 @@ , "complete --no-files --command " ++ progn ++ " --arguments '(_" ++ progn ++ ")'" ] -zshCompletionScript :: String -> String -> IO [String]-zshCompletionScript prog progn = return+-- | Generated zsh shell completion script+zshCompletionScript :: String -> String -> String+zshCompletionScript prog progn = unlines [ "#compdef " ++ progn , "" , "local request"
src/Options/Applicative/Builder.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} module Options.Applicative.Builder ( -- * Parser builders --@@ -26,7 +27,6 @@ infoOption, strOption, option,- nullOption, -- * Modifiers short,@@ -49,6 +49,7 @@ completer, idm, mappend,+ parserOptionGroup, -- * Readers --@@ -74,6 +75,7 @@ failureCode, noIntersperse, forwardOptions,+ allPositional, info, -- * Builder for 'ParserPrefs'@@ -86,6 +88,9 @@ subparserInline, columns, helpLongEquals,+ helpShowGlobals,+ helpIndent,+ briefHangPoint, prefs, defaultPrefs, @@ -104,7 +109,9 @@ ) where import Control.Applicative-import Data.Semigroup hiding (option)+#if __GLASGOW_HASKELL__ < 804+import Data.Semigroup hiding (Option, option)+#endif import Data.String (fromString, IsString) import Options.Applicative.Builder.Completer@@ -113,6 +120,7 @@ import Options.Applicative.Types import Options.Applicative.Help.Pretty import Options.Applicative.Help.Chunk+import Options.Applicative.Internal (mapParserOptions) -- Readers -- @@ -184,7 +192,7 @@ 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'+-- | Specify the help text for an option as a 'Prettyprinter.Doc AnsiStyle' -- value. helpDoc :: Maybe Doc -> Mod f a helpDoc doc = optionMod $ \p -> p { propHelp = Chunk doc }@@ -201,6 +209,8 @@ metavar var = optionMod $ \p -> p { propMetaVar = var } -- | Hide this option from the brief description.+--+-- Use 'internal' to hide the option from the help text too. hidden :: Mod f a hidden = optionMod $ \p -> p { propVisibility = min Hidden (propVisibility p) }@@ -208,11 +218,11 @@ -- | Apply a function to the option description in the usage text. -- -- > import Options.Applicative.Help--- > flag' () (short 't' <> style bold)+-- > flag' () (short 't' <> style (annotate bold)) -- -- /NOTE/: This builder is more flexible than its name and example -- allude. One of the motivating examples for its addition was to--- used `const` to completely replace the usage text of an option.+-- use `const` to completely replace the usage text of an option. style :: ( Doc -> Doc ) -> Mod f a style x = optionMod $ \p -> p { propDescMod = Just x }@@ -266,17 +276,23 @@ -- | Builder for a command parser. The 'command' modifier can be used to -- specify individual commands.+--+-- By default, sub-parsers allow backtracking to their parent's options when+-- they are completed. To allow full mixing of parent and sub-parser options,+-- turn on 'subparserInline'; otherwise, to disable backtracking completely,+-- use 'noBacktrack'. subparser :: Mod CommandFields a -> Parser a subparser m = mkParser d g rdr where Mod _ d g = metavar "COMMAND" `mappend` m- (groupName, cmds, subs) = mkCommand m- rdr = CmdReader groupName cmds subs+ (groupName, cmds) = mkCommand m+ rdr = CmdReader groupName cmds -- | Builder for an argument parser. argument :: ReadM a -> Mod ArgumentFields a -> Parser a-argument p (Mod f d g) = mkParser d g (ArgReader rdr)+argument p m = mkParser d g (ArgReader rdr) where+ (Mod f d g) = noGlobal `mappend` m ArgumentFields compl = f (ArgumentFields mempty) rdr = CReader compl p @@ -351,11 +367,6 @@ 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@@ -371,6 +382,56 @@ crdr = CReader (optCompleter fields) r rdr = OptReader (optNames fields) crdr (optNoArgError fields) +-- | Prepends a group to 'OptProperties'. Nested groups are indented e.g.+--+-- @+-- optPropertiesGroup "Group Outer" (optPropertiesGroup "Group Inner" o)+-- @+--+-- will render as:+--+-- @+-- Group Outer+-- - Group Inner+-- ...+-- @+optPropertiesGroup :: String -> OptProperties -> OptProperties+optPropertiesGroup g o = o { propGroup = OptGroup (g : oldGroup) }+ where+ OptGroup oldGroup = propGroup o++-- | Prepends a group per 'optPropertiesGroup'.+optionGroup :: String -> Option a -> Option a+optionGroup grp o = o { optProps = props' }+ where+ props' = optPropertiesGroup grp (optProps o)++-- | Group options together under a common heading in the help text.+--+-- For example, if we have:+--+-- > Args+-- > <$> parseMain+-- > <*> parserOptionGroup "Group A" parseA+-- > <*> parserOptionGroup "Group B" parseB+-- > <*> parseOther+--+-- Then the help page will look like:+--+-- > Available options:+-- > <main options>+-- > <other options>+-- >+-- > Group A+-- > <A options>+-- >+-- > Group B+-- > <B options>+--+-- @since 0.19.0.0+parserOptionGroup :: String -> Parser a -> Parser a+parserOptionGroup g = mapParserOptions (optionGroup g)+ -- | Modifier for 'ParserInfo'. newtype InfoMod a = InfoMod { applyInfoMod :: ParserInfo a -> ParserInfo a }@@ -382,7 +443,7 @@ instance Semigroup (InfoMod a) where m1 <> m2 = InfoMod $ applyInfoMod m2 . applyInfoMod m1 --- | Show a full description in the help text of this parser.+-- | Show a full description in the help text of this parser (default). fullDesc :: InfoMod a fullDesc = InfoMod $ \i -> i { infoFullDesc = True } @@ -394,7 +455,7 @@ 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'+-- | Specify a header for this parser as a 'Prettyprinter.Doc AnsiStyle' -- value. headerDoc :: Maybe Doc -> InfoMod a headerDoc doc = InfoMod $ \i -> i { infoHeader = Chunk doc }@@ -403,7 +464,7 @@ 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'+-- | Specify a footer for this parser as a 'Prettyprinter.Doc AnsiStyle' -- value. footerDoc :: Maybe Doc -> InfoMod a footerDoc doc = InfoMod $ \i -> i { infoFooter = Chunk doc }@@ -412,7 +473,7 @@ progDesc :: String -> InfoMod a progDesc s = InfoMod $ \i -> i { infoProgDesc = paragraph s } --- | Specify a short program description as a 'Text.PrettyPrint.ANSI.Leijen.Doc'+-- | Specify a short program description as a 'Prettyprinter.Doc AnsiStyle' -- value. progDescDoc :: Maybe Doc -> InfoMod a progDescDoc doc = InfoMod $ \i -> i { infoProgDesc = Chunk doc }@@ -438,6 +499,14 @@ forwardOptions :: InfoMod a forwardOptions = InfoMod $ \p -> p { infoPolicy = ForwardOptions } +-- | Disable parsing of regular options completely. All options and arguments+-- will be treated as a positional arguments. Obviously not recommended in+-- general as options will be unreachable.+-- This is the same behaviour one sees after the "--" pseudo-argument.+allPositional :: InfoMod a+allPositional = InfoMod $ \p -> p { infoPolicy = AllPositionals }++ -- | Create a 'ParserInfo' given a 'Parser' and a modifier. info :: Parser a -> InfoMod a -> ParserInfo a info parser m = applyInfoMod m base@@ -506,6 +575,19 @@ helpLongEquals :: PrefsMod helpLongEquals = PrefsMod $ \p -> p { prefHelpLongEquals = True } +-- | Show global help information in subparser usage.+helpShowGlobals :: PrefsMod+helpShowGlobals = PrefsMod $ \p -> p { prefHelpShowGlobal = True }++-- | Set fill width in help text presentation.+helpIndent :: Int -> PrefsMod+helpIndent w = PrefsMod $ \p -> p { prefTabulateFill = w }++-- | Set the width at which to hang the brief help text.+briefHangPoint :: Int -> PrefsMod+briefHangPoint php = PrefsMod $ \p -> p { prefBriefHangPoint = php }++ -- | Create a `ParserPrefs` given a modifier prefs :: PrefsMod -> ParserPrefs prefs m = applyPrefsMod m base@@ -517,7 +599,10 @@ , prefShowHelpOnEmpty = False , prefBacktrack = Backtrack , prefColumns = 80- , prefHelpLongEquals = False }+ , prefHelpLongEquals = False+ , prefHelpShowGlobal = False+ , prefTabulateFill = 24+ , prefBriefHangPoint = 35 } -- Convenience shortcuts
src/Options/Applicative/Builder/Completer.hs view
@@ -1,16 +1,22 @@+{-# LANGUAGE CPP #-}+ module Options.Applicative.Builder.Completer ( Completer , mkCompleter , listIOCompleter , listCompleter , bashCompleter++ , requote ) where import Control.Applicative import Prelude import Control.Exception (IOException, try) import Data.List (isPrefixOf)+#ifdef MIN_VERSION_process import System.Process (readProcess)+#endif import Options.Applicative.Types @@ -31,10 +37,14 @@ -- <http://www.gnu.org/software/bash/manual/html_node/Programmable-Completion-Builtins.html#Programmable-Completion-Builtins> -- for a complete list. bashCompleter :: String -> Completer+#ifdef MIN_VERSION_process bashCompleter action = Completer $ \word -> do let cmd = unwords ["compgen", "-A", action, "--", requote word] result <- tryIO $ readProcess "bash" ["-c", cmd] "" return . lines . either (const []) id $ result+#else+bashCompleter = const $ Completer $ const $ return []+#endif tryIO :: IO a -> IO (Either IOException a) tryIO = try
src/Options/Applicative/Builder/Internal.hs view
@@ -20,7 +20,8 @@ mkOption, mkProps, - internal+ internal,+ noGlobal ) where import Control.Applicative@@ -119,7 +120,8 @@ -- 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+-- sufficient to pass them to builders (such as 'Options.Applicative.strOption'+-- or 'Options.Applicative.flag') to -- create options (see 'Options.Applicative.Builder'). data Mod f a = Mod (f a -> f a) (DefaultProp a)@@ -148,10 +150,12 @@ , propHelp = mempty , propShowDefault = Nothing , propDescMod = Nothing+ , propShowGlobal = True+ , propGroup = OptGroup [] } -mkCommand :: Mod CommandFields a -> (Maybe String, [String], String -> Maybe (ParserInfo a))-mkCommand m = (group, map fst cmds, (`lookup` cmds))+mkCommand :: Mod CommandFields a -> (Maybe String, [(String, ParserInfo a)])+mkCommand m = (group, cmds) where Mod f _ _ = m CommandFields cmds group = f (CommandFields [] Nothing)@@ -180,6 +184,14 @@ props = (g baseProps) { propShowDefault = sdef <*> def } --- | Hide this option from the help text+-- | Hide this option completely from the help text+--+-- Use 'Options.Applicative.hidden' if the option should remain visible in the+-- full description. internal :: Mod f a internal = optionMod $ \p -> p { propVisibility = Internal }+++-- | Suppress this option from appearing in global options+noGlobal :: Mod f a+noGlobal = optionMod $ \pp -> pp { propShowGlobal = False }
src/Options/Applicative/Common.hs view
@@ -41,6 +41,7 @@ -- * Running parsers runParserInfo, runParserFully,+ runParserStep, runParser, evalParser, @@ -161,27 +162,35 @@ 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+searchArg prefs arg =+ searchParser $ \opt -> do+ when (isArg (optMain opt)) cut+ case optMain opt of+ CmdReader _ cs -> do+ subp <- hoistList (cmdMatches cs)+ case prefBacktrack prefs of+ NoBacktrack -> lift $ do+ args <- get <* put []+ fmap pure . lift $ enterContext arg subp *> runParserInfo subp args <* exitContext - (Just subp, Backtrack) -> fmap pure . lift . StateT $ \args ->- enterContext arg subp *> runParser (infoPolicy subp) CmdStart (infoParser subp) args <* exitContext+ 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+ SubparserInline -> lift $ do+ lift $ enterContext arg subp+ return $ infoParser subp - (Nothing, _) -> mzero- ArgReader rdr ->- fmap pure . lift . lift $ runReadM (crReader rdr) arg- _ -> mzero+ ArgReader rdr ->+ fmap pure . lift . lift $ runReadM (crReader rdr) arg + _ ->+ mzero++ where+ cmdMatches cs+ | prefDisambiguate prefs = snd <$> filter (isPrefixOf arg . fst) cs+ | otherwise = maybeToList (lookup arg cs)+ stepParser :: MonadP m => ParserPrefs -> ArgPolicy -> String -> Parser a -> NondetT (StateT Args m) (Parser a) stepParser pprefs AllPositionals arg p =@@ -203,21 +212,27 @@ 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+ (mp', args') <- do_step arg argt case mp' of Nothing -> hoistMaybe result <|> parseError arg p Just p' -> runParser (newPolicy arg) CmdCont p' args' where- result = (,) <$> evalParser p <*> pure args- do_step prefs arg argt = (`runStateT` argt)- . disamb (not (prefDisambiguate prefs))- $ stepParser prefs policy arg p+ result =+ (,) <$> evalParser p <*> pure args+ do_step =+ runParserStep policy p newPolicy a = case policy of NoIntersperse -> if isJust (parseWord a) then NoIntersperse else AllPositionals x -> x +runParserStep :: MonadP m => ArgPolicy -> Parser a -> String -> Args -> m (Maybe (Parser a), Args)+runParserStep policy p arg args = do+ prefs <- getPrefs+ flip runStateT args+ $ disamb (not (prefDisambiguate prefs))+ $ stepParser prefs policy arg p+ parseError :: MonadP m => String -> Parser x -> m a parseError arg = errorP . UnexpectedError arg . SomeParser @@ -242,39 +257,39 @@ -- | 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)+mapParser :: (forall x. ArgumentReachability -> Option x -> b) -> Parser a -> [b] mapParser f = flatten . treeMapParser f where flatten (Leaf x) = [x] flatten (MultNode xs) = xs >>= flatten flatten (AltNode _ xs) = xs >>= flatten+ flatten (BindNode x) = flatten x -- | Like 'mapParser', but collect the results in a tree structure.-treeMapParser :: (forall x . OptHelpInfo -> Option x -> b)- -> Parser a- -> OptTree b-treeMapParser g = simplify . go False False g+treeMapParser :: (forall x. ArgumentReachability -> Option x -> b)+ -> Parser a+ -> OptTree b+treeMapParser g = simplify . go False g where has_default :: Parser a -> Bool has_default p = isJust (evalParser p) go :: Bool- -> Bool- -> (forall x . OptHelpInfo -> Option x -> b)+ -> (forall x. ArgumentReachability -> Option x -> b) -> Parser a -> OptTree b- go _ _ _ (NilP _) = MultNode []- go m r f (OptP opt)+ go _ _ (NilP _) = MultNode []+ go r f (OptP opt) | optVisibility opt > Internal- = Leaf (f (OptHelpInfo m r) opt)+ = Leaf (f (ArgumentReachability r) opt) | otherwise = MultNode []- go m r f (MultP p1 p2) =- MultNode [go m r f p1, go m r' f p2]+ go r f (MultP p1 p2) =+ MultNode [go r f p1, go 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]+ go r f (AltP p1 p2) =+ AltNode altNodeType [go r f p1, go r f p2] where -- The 'AltNode' indicates if one of the branches has a default. -- This is used for rendering brackets, as well as filtering@@ -284,11 +299,11 @@ then MarkDefault else NoDefault - go _ r f (BindP p k) =- let go' = go True r f p+ go r f (BindP p k) =+ let go' = go r f p in case evalParser p of- Nothing -> go'- Just aa -> MultNode [ go', go True r f (k aa) ]+ Nothing -> BindNode go'+ Just aa -> BindNode (MultNode [ go', go r f (k aa) ]) hasArg :: Parser a -> Bool hasArg (NilP _) = False@@ -312,3 +327,5 @@ remove_alt (AltNode _ ts) = ts remove_alt (MultNode []) = [] remove_alt t = [t]+simplify (BindNode x) =+ BindNode $ simplify x
src/Options/Applicative/Extra.hs view
@@ -4,11 +4,11 @@ -- -- | This module contains high-level functions to run parsers. helper,+ helperWith, hsubparser,+ simpleVersioner, execParser,- execParserMaybe, customExecParser,- customExecParserMaybe, execParserPure, getParseResult, handleParseResult,@@ -22,7 +22,9 @@ ) where import Control.Applicative+import Control.Monad (void) import Data.Monoid+import Data.Foldable (traverse_) import Prelude import System.Environment (getArgs, getProgName) import System.Exit (exitSuccess, exitWith, ExitCode(..))@@ -46,12 +48,40 @@ -- > opts = info (sample <**> helper) mempty helper :: Parser (a -> a)-helper = abortOption ShowHelpText $ mconcat- [ long "help"- , short 'h'- , help "Show this help text"- , hidden ]+helper =+ helperWith (mconcat [+ long "help",+ short 'h',+ help "Show this help text"+ ]) +-- | Like helper, but with a minimal set of modifiers that can be extended+-- as desired.+--+-- > opts :: ParserInfo Sample+-- > opts = info (sample <**> helperWith (mconcat [+-- > long "help",+-- > short 'h',+-- > help "Show this help text",+-- > hidden+-- > ])) mempty+helperWith :: Mod OptionFields (a -> a) -> Parser (a -> a)+helperWith modifiers =+ option helpReader $+ mconcat+ [ value id,+ metavar "",+ noGlobal,+ noArgError (ShowHelpText Nothing),+ hidden,+ modifiers+ ]+ where+ helpReader = do+ potentialCommand <- readerAsk+ readerAbort $+ ShowHelpText (Just potentialCommand)+ -- | Builder for a command parser with a \"helper\" option attached. -- Used in the same way as `subparser`, but includes a \"--help|-h\" inside -- the subcommand.@@ -59,11 +89,24 @@ 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)+ (groupName, cmds) = mkCommand m+ rdr = CmdReader groupName ((fmap . fmap) add_helper cmds) add_helper pinfo = pinfo { infoParser = infoParser pinfo <**> helper } +-- | A hidden \"--version\" option that displays the version.+--+-- > opts :: ParserInfo Sample+-- > opts = info (sample <**> simpleVersioner "v1.2.3") mempty+simpleVersioner :: String -- ^ Version string to be shown+ -> Parser (a -> a)+simpleVersioner version = infoOption version $+ mconcat+ [ long "version"+ , help "Show version information"+ , hidden+ ]+ -- | Run a program description. -- -- Parse command line arguments. Display help text and exit if any parse error@@ -104,24 +147,6 @@ 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@@ -142,25 +167,39 @@ -- -- This function can be used, for example, to show the help text for a parser: ----- @handleParseResult . Failure $ parserFailure pprefs pinfo ShowHelpText mempty@+-- @handleParseResult . Failure $ parserFailure pprefs pinfo (ShowHelpText Nothing) mempty@ parserFailure :: ParserPrefs -> ParserInfo a -> ParseError -> [Context] -> ParserFailure ParserHelp-parserFailure pprefs pinfo msg ctx = ParserFailure $ \progn ->+parserFailure pprefs pinfo msg ctx0 = ParserFailure $ \progn -> let h = with_context ctx pinfo $ \names pinfo' -> mconcat [ base_help pinfo' , usage_help progn names pinfo' , suggestion_help+ , globals ctx , error_help ] in (h, exit_code, prefColumns pprefs) where+ --+ -- Add another context layer if the argument to --help is+ -- a valid command.+ ctx = case msg of+ ShowHelpText (Just potentialCommand) ->+ let ctx1 = with_context ctx0 pinfo $ \_ pinfo' ->+ snd+ $ flip runP defaultPrefs { prefBacktrack = SubparserInline }+ $ runParserStep (infoPolicy pinfo') (infoParser pinfo') potentialCommand []+ in ctx1 `mappend` ctx0+ _ ->+ ctx0+ exit_code = case msg of ErrorMsg {} -> ExitFailure (infoFailureCode pinfo) UnknownError -> ExitFailure (infoFailureCode pinfo) MissingError {} -> ExitFailure (infoFailureCode pinfo) ExpectsArgError {} -> ExitFailure (infoFailureCode pinfo) UnexpectedError {} -> ExitFailure (infoFailureCode pinfo)- ShowHelpText -> ExitSuccess+ ShowHelpText {} -> ExitSuccess InfoMsg {} -> ExitSuccess with_context :: [Context]@@ -170,16 +209,32 @@ with_context [] i f = f [] i with_context c@(Context _ i:_) _ f = f (contextNames c) i + globals :: [Context] -> ParserHelp+ globals cs =+ let+ voided =+ fmap (\(Context _ p) -> void p) cs `mappend` pure (void pinfo)++ globalParsers =+ traverse_ infoParser $+ drop 1 voided+ in+ if prefHelpShowGlobal pprefs then+ parserGlobals pprefs globalParsers+ else+ mempty+ usage_help progn names i = case msg of InfoMsg _ -> mempty _- -> usageHelp $ vcatChunks- [ pure . parserUsage pprefs (infoParser i) . unwords $ progn : names- , fmap (indent 2) . infoProgDesc $ i ]+ -> mconcat [+ usageHelp (pure . parserUsage pprefs (infoParser i) . unwords $ progn : names)+ , descriptionHelp (infoProgDesc i)+ ] error_help = errorHelp $ case msg of- ShowHelpText+ ShowHelpText {} -> mempty ErrorMsg m@@ -233,9 +288,10 @@ -- -- 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?"+ 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@@ -257,14 +313,14 @@ -- 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+ opt_completions reachability opt = case optMain opt of OptReader ns _ _ -> fmap showOption ns FlagReader ns _ -> fmap showOption ns ArgReader _ -> []- CmdReader _ ns _ | hinfoUnreachableArgs hinfo+ CmdReader _ ns | argumentIsUnreachable reachability -> [] | otherwise- -> ns+ -> fst <$> ns _ -> mempty @@ -279,7 +335,7 @@ f = footerHelp (infoFooter i) show_full_help = case msg of- ShowHelpText -> True+ ShowHelpText {} -> True MissingError CmdStart _ | prefShowHelpOnEmpty pprefs -> True InfoMsg _ -> False
src/Options/Applicative/Help/Chunk.hs view
@@ -1,6 +1,5 @@ module Options.Applicative.Help.Chunk- ( mappendWith- , Chunk(..)+ ( Chunk(..) , chunked , listToChunk , (<<+>>)@@ -23,10 +22,7 @@ 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'.+-- | The free monoid on a semigroup @a@. newtype Chunk a = Chunk { unChunk :: Maybe a } deriving (Eq, Show)@@ -57,7 +53,8 @@ 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'.+-- | 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)@@ -119,7 +116,7 @@ -- > extractChunk . stringChunk = string stringChunk :: String -> Chunk Doc stringChunk "" = mempty-stringChunk s = pure (string s)+stringChunk s = pure (pretty s) -- | Convert a paragraph into a 'Chunk'. The resulting chunk is composed by the -- words of the original paragraph separated by softlines, so it will be@@ -132,12 +129,9 @@ paragraph = foldr (chunked (</>) . stringChunk) mempty . words -tabulate' :: Int -> [(Doc, Doc)] -> Chunk Doc-tabulate' _ [] = mempty-tabulate' size table = pure $ vcat+-- | Display pairs of strings in a table.+tabulate :: Int -> [(Doc, Doc)] -> Chunk Doc+tabulate _ [] = mempty+tabulate size table = pure $ vcat [ indent 2 (fillBreak size key <+> value) | (key, value) <- table ]---- | Display pairs of strings in a table.-tabulate :: [(Doc, Doc)] -> Chunk Doc-tabulate = tabulate' 24
src/Options/Applicative/Help/Core.hs view
@@ -1,89 +1,104 @@+{-# LANGUAGE CPP #-} module Options.Applicative.Help.Core ( cmdDesc, briefDesc, missingDesc, fullDesc,+ globalDesc, ParserHelp(..), errorHelp, headerHelp, suggestionsHelp, usageHelp,+ descriptionHelp, bodyHelp, footerHelp,+ globalsHelp, parserHelp, parserUsage,+ parserGlobals ) where -import Control.Applicative-import Control.Monad (guard)-import Data.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 Control.Applicative+import Control.Monad (guard) +import Data.Foldable (any, foldl')+import Data.Function (on)+import qualified Data.List as List+import Data.List.NonEmpty (NonEmpty ((:|)))+import qualified Data.List.NonEmpty as NE+import Data.Maybe (fromMaybe, catMaybes)++import Prelude hiding (any)+ import Options.Applicative.Common import Options.Applicative.Types import Options.Applicative.Help.Pretty import Options.Applicative.Help.Chunk -- | Style for rendering an option.-data OptDescStyle = OptDescStyle- { descSep :: Doc- , descHidden :: Bool }+data OptDescStyle+ = OptDescStyle+ { descSep :: Doc,+ descHidden :: Bool,+ descGlobal :: Bool+ } safelast :: [a] -> Maybe a-safelast = foldl (const Just) Nothing+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)+optDesc :: ParserPrefs -> OptDescStyle -> ArgumentReachability -> Option a -> (OptGroup, Chunk Doc, Parenthetic)+optDesc pprefs style _reachability opt =+ let names =+ List.sort . optionNames . optMain $ opt+ meta =+ stringChunk $ optMetaVar opt+ grp = propGroup $ optProps opt+ descs =+ map (pretty . showOption) names+ descriptions =+ listToChunk (List.intersperse (descSep style) descs) desc- | prefHelpLongEquals pprefs && not (isEmpty meta) && any isLongName (safelast names)- = descriptions <> stringChunk "=" <> meta- | otherwise- = descriptions <<+>> meta+ | 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+ | descGlobal style && not (propShowGlobal (optProps opt)) =+ False+ | optVisibility opt == Hidden =+ descHidden style+ | otherwise =+ optVisibility opt == Visible wrapping- = wrapIf (length names > 1)+ | null names =+ NeverRequired+ | length names == 1 =+ MaybeRequired+ | otherwise =+ AlwaysRequired rendered- | not show_opt- = mempty- | otherwise- = desc <> suffix- modified- = maybe id fmap (optDescMod opt) rendered- in (modified, wrapping)+ | not show_opt =+ mempty+ | otherwise =+ desc+ modified =+ maybe id fmap (optDescMod opt) rendered+ in (grp, modified, wrapping) -- | Generate descriptions for commands.-cmdDesc :: Parser a -> [(Maybe String, Chunk Doc)]-cmdDesc = mapParser desc+cmdDesc :: ParserPrefs -> Parser a -> [(Maybe String, Chunk Doc)]+cmdDesc pprefs = 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 ]+ CmdReader gn cmds ->+ (,) gn $+ tabulate (prefTabulateFill pprefs)+ [ (pretty nm, align (extractChunk (infoProgDesc cmd)))+ | (nm, cmd) <- reverse cmds+ ] _ -> mempty -- | Generate a brief help text for a parser.@@ -98,68 +113,251 @@ -- | 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)+briefDesc' showOptional pprefs =+ wrapOver NoDefault MaybeRequired+ . foldTree pprefs style+ . mFilterOptional+ . treeMapParser optDesc' where- mfilterOptional- | showOptional- = id- | otherwise- = filterOptional-+ mFilterOptional+ | showOptional =+ id+ | otherwise =+ filterOptional style = OptDescStyle- { descSep = string "|"- , descHidden = False }+ { descSep = pretty '|',+ descHidden = False,+ descGlobal = False+ }+ optDesc' reach opt =+ let+ (_, a, b) =+ optDesc pprefs style reach opt+ in+ (a, b) -- | Wrap a doc in parentheses or brackets if required.-wrap :: AltNodeType -> (Chunk Doc, Wrapping) -> Chunk Doc-wrap altnode (chunk, wrapping)- | altnode == MarkDefault- = fmap brackets chunk- | needsWrapping wrapping- = fmap parens chunk- | otherwise- = chunk+wrapOver :: AltNodeType -> Parenthetic -> (Chunk Doc, Parenthetic) -> Chunk Doc+wrapOver altnode mustWrapBeyond (chunk, wrapping)+ | altnode == MarkDefault =+ fmap brackets chunk+ | wrapping > mustWrapBeyond =+ fmap parens chunk+ | otherwise =+ chunk -- Fold a tree of option docs into a single doc with fully marked -- optional areas and groups.-foldTree :: 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))- . fmap groupOrNestLine- . wrap b- . alt_node- . filter (not . isEmpty . fst)- . map foldTree $ xs- where+foldTree :: ParserPrefs -> OptDescStyle -> OptTree (Chunk Doc, Parenthetic) -> (Chunk Doc, Parenthetic)+foldTree _ _ (Leaf x) =+ x+foldTree prefs s (MultNode xs) =+ let go =+ (<</>>) . wrapOver NoDefault MaybeRequired . foldTree prefs s+ x =+ foldr go mempty xs+ wrapLevel =+ multi_wrap xs+ in (x, wrapLevel)+ where+ multi_wrap [_] = NeverRequired+ multi_wrap _ = MaybeRequired+foldTree prefs s (AltNode b xs) =+ (\x -> (x, NeverRequired))+ . fmap groupOrNestLine+ . wrapOver b MaybeRequired+ . alt_node+ . filter (not . isEmpty . fst)+ . map (foldTree prefs s)+ $ xs+ where+ alt_node :: [(Chunk Doc, Parenthetic)] -> (Chunk Doc, Parenthetic)+ alt_node [n] = n+ alt_node ns =+ (\y -> (y, AlwaysRequired))+ . foldr (chunked altSep . wrapOver NoDefault MaybeRequired) mempty+ $ ns+foldTree prefs s (BindNode x) =+ let rendered =+ wrapOver NoDefault NeverRequired (foldTree prefs s x) - alt_node :: [(Chunk Doc, Wrapping)] -> (Chunk Doc, Wrapping)- alt_node [n] = n- alt_node ns = (\y -> (y, Wrapped))- . foldr (chunked altSep . wrap NoDefault) mempty- $ ns+ -- We always want to display the rendered option+ -- if it exists, and only attach the suffix then.+ withSuffix =+ rendered >>= (\r -> pure r <> stringChunk (prefMultiSuffix prefs))+ in (withSuffix, NeverRequired) --- | Generate a full help text for a parser.+-- | Generate a full help text for a parser fullDesc :: ParserPrefs -> Parser a -> Chunk Doc-fullDesc pprefs = tabulate . catMaybes . mapParser doc+fullDesc = optionsDesc False++-- | Generate a help text for the parser, showing+-- only what is relevant in the "Global options: section"+globalDesc :: ParserPrefs -> Parser a -> Chunk Doc+globalDesc = optionsDesc True++-- | Common generator for full descriptions and globals+optionsDesc :: Bool -> ParserPrefs -> Parser a -> Chunk Doc+optionsDesc global pprefs p =+ vsepChunks+ . formatTitle'+ . fmap tabulateGroup+ . groupByTitle+ $ docs where+ docs :: [Maybe (OptGroup, (Doc, Doc))]+ docs = mapParser doc p++ groupByTitle :: [Maybe (OptGroup, (Doc, Doc))] -> [[(OptGroup, (Doc, Doc))]]+ groupByTitle xs = groupFstAll . catMaybes $ xs++ -- NOTE: [Nested group alignment]+ --+ -- For nested groups, we want to produce output like:+ --+ -- Group 1+ -- --opt-1 INT Option 1+ --+ -- - Group 2+ -- --opt-2 INT Option 2+ --+ -- - Group 3+ -- - opt-3 INT Option 3+ --+ -- That is, we have the following constraints:+ --+ -- 1. Nested groups are prefixed with a hyphen '- ', where the hyphen+ -- starts on the same column as the parent group.+ --+ -- 2. We still want the listed options to be indented twice under the+ -- group name, so this means nested options need to be indented+ -- again by the standard amount (2), due to the hyphen.+ --+ -- 3. Help text should be __globally__ aligned.++ tabulateGroup :: [(OptGroup, (Doc, Doc))] -> (OptGroup, Chunk Doc)+ tabulateGroup l@((title,_):_) =+ (title, tabulate (prefTabulateFill pprefs) (getGroup <$> l))+ where+ -- Handle NOTE: [Nested group alignment] 3. here i.e. indent the+ -- right Doc (help text) according to its indention level and+ -- global maxGroupLevel. Notice there is an inverse relationship here,+ -- as the further the entire group is indented, the less we need to+ -- indent the help text.+ getGroup :: (OptGroup, (Doc, Doc)) -> (Doc, Doc)+ getGroup o@(_, (x, y)) =+ let helpIndent = calcOptHelpIndent o+ in (x, indent helpIndent y)++ -- Indents the option help text, taking the option's group level and+ -- maximum group level into account.+ calcOptHelpIndent :: (OptGroup, a) -> Int+ calcOptHelpIndent g =+ let groupLvl = optGroupToLevel g+ in lvlIndent * (maxGroupLevel - groupLvl)++ tabulateGroup [] = (OptGroup [], mempty)++ -- Fold so we can update the (printedGroups :: [String]) arg as we+ -- iterate. End with a reverse since we use foldl'.+ formatTitle' :: [(OptGroup, Chunk Doc)] -> [Chunk Doc]+ formatTitle' = reverse . snd . foldl' formatTitle ([], [])++ formatTitle :: ([String], [Chunk Doc]) -> (OptGroup, Chunk Doc) -> ([String], [Chunk Doc])+ formatTitle (printedGroups, acc) o@(OptGroup groups, opts) =+ case parentGroups of+ -- No nested groups: No special logic.+ [] -> (groupTitle : printedGroups, ((\d -> pretty groupTitle .$. d) <$> opts) : acc)+ -- We have at least one parent group title P for current group G: P has+ -- already been printed iff it is attached to another (non-grouped)+ -- option. In other words, P has __not__ been printed if its only+ -- member is another group.+ --+ -- The parameter (printedGroups :: [String]) holds all groups that+ -- have already been printed.+ parents@(_ : _) ->+ let groupLvl = optGroupToLevel o+ -- indent opts an extra lvlIndent to account for hyphen+ indentOpts = indent lvlIndent++ -- new printedGroups is all previous + this and parents.+ printedGroups' = groupTitle : parents ++ printedGroups++ parentsWithIndent = zip [0 .. ] parents++ -- docs for unprinted parent title groups+ parentDocs = pure $ mkParentDocs printedGroups parentsWithIndent++ -- docs for the current group+ thisDocs =+ (\d -> lvlIndentNSub1 groupLvl $ (hyphenate groupTitle) .$. indentOpts d)+ <$> opts++ allDocs = parentDocs <> thisDocs++ in (printedGroups', allDocs : acc)+ where+ -- Separate parentGroups and _this_ group, in case we need to also+ -- print parent groups.+ (parentGroups, groupTitle) = case unsnoc groups of+ Nothing -> ([], defTitle)+ Just (parentGrps, grp) -> (parentGrps, grp)++ defTitle =+ if global+ then "Global options:"+ else "Available options:"++ maxGroupLevel :: Int+ maxGroupLevel = findMaxGroupLevel docs++ -- Finds the maxium OptGroup level.+ findMaxGroupLevel :: [Maybe (OptGroup, (Doc, Doc))] -> Int+ findMaxGroupLevel = foldl' (\acc -> max acc . optGroupToLevel) 0 . catMaybes++ optGroupToLevel :: (OptGroup, a) -> Int+ -- 0 (defTitle) and 1 (custom group name) are handled identically+ -- w.r.t indenation (not indented). Hence the subtraction here.+ optGroupToLevel (OptGroup [], _) = 0+ optGroupToLevel (OptGroup xs@(_ : _), _) = length xs - 1++ doc :: ArgumentReachability -> Option a -> Maybe (OptGroup, (Doc, Doc)) doc info opt = do guard . not . isEmpty $ n guard . not . isEmpty $ h- return (extractChunk n, align . extractChunk $ h <<+>> hdef)+ return (grp, (extractChunk n, align . extractChunk $ h <</>> hdef)) where- n = fst $ optDesc pprefs style info opt+ (grp, n, _) = optDesc pprefs style info opt h = optHelp opt hdef = Chunk . fmap show_def . optShowDefault $ opt- show_def s = parens (string "default:" <+> string s)+ show_def s = parens (pretty "default:" <+> pretty s) style = OptDescStyle- { descSep = string ","- , descHidden = True }+ { descSep = pretty ',',+ descHidden = True,+ descGlobal = global+ } + --+ -- Prints all parent titles that have not already been printed+ -- (i.e. in printedGroups).+ mkParentDocs :: [String] -> [(Int, String)] -> Doc+ mkParentDocs printedGroups =+ foldr g mempty+ where+ g :: (Int, String) -> Doc -> Doc+ g (i, s) acc+ | s `List.elem` printedGroups = acc+ | i == 0 = pretty s .$. acc+ | otherwise = lvlIndentNSub1 i $ hyphenate s .$. acc++ hyphenate s = pretty ("- " <> s)++ lvlIndentNSub1 :: Int -> Doc -> Doc+ lvlIndentNSub1 n = indent (lvlIndent * (n - 1))++ lvlIndent :: Int+ lvlIndent = 2+ errorHelp :: Chunk Doc -> ParserHelp errorHelp chunk = mempty { helpError = chunk } @@ -169,9 +367,15 @@ suggestionsHelp :: Chunk Doc -> ParserHelp suggestionsHelp chunk = mempty { helpSuggestions = chunk } +globalsHelp :: Chunk Doc -> ParserHelp+globalsHelp chunk = mempty { helpGlobals = chunk }+ usageHelp :: Chunk Doc -> ParserHelp usageHelp chunk = mempty { helpUsage = chunk } +descriptionHelp :: Chunk Doc -> ParserHelp+descriptionHelp chunk = mempty { helpDescription = chunk }+ bodyHelp :: Chunk Doc -> ParserHelp bodyHelp chunk = mempty { helpBody = chunk } @@ -180,36 +384,103 @@ -- | 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)+parserHelp pprefs p =+ bodyHelp . vsepChunks $+ fullDesc pprefs p+ : (group_title <$> cs) where def = "Available commands:"-- cs = groupBy ((==) `on` fst) $ cmdDesc p+ cs = groupFstAll $ cmdDesc pprefs p - group_title a@((n,_):_) = with_title (fromMaybe def n) $- vcatChunks (snd <$> a)+ 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 .$.)+ with_title title = fmap (pretty title .$.) ++parserGlobals :: ParserPrefs -> Parser a -> ParserHelp+parserGlobals pprefs p =+ globalsHelp $ globalDesc pprefs p+++ -- | Generate option summary. parserUsage :: ParserPrefs -> Parser a -> String -> Doc-parserUsage pprefs p progn = hsep- [ string "Usage:"- , string progn- , align (extractChunk (briefDesc pprefs p)) ]+parserUsage pprefs p progn =+ group $+ hsep+ [ pretty "Usage:",+ pretty progn,+ hangAtIfOver 9 (prefBriefHangPoint pprefs) (extractChunk (briefDesc pprefs p))+ ] -data Wrapping- = Bare- | Wrapped- deriving (Eq, Show)+-- | Peek at the structure of the rendered tree within.+--+-- For example, if a child is an option with multiple+-- alternatives, such as -a or -b, we need to know this+-- when wrapping it. For example, whether it's optional:+-- we don't want to have [(-a|-b)], rather [-a|-b] or+-- (-a|-b).+data Parenthetic+ = NeverRequired+ -- ^ Parenthesis are not required.+ | MaybeRequired+ -- ^ Parenthesis should be used if this group can be repeated+ | AlwaysRequired+ -- ^ Parenthesis should always be used.+ deriving (Eq, Ord, Show) -wrapIf :: Bool -> Wrapping-wrapIf b = if b then Wrapped else Bare+-- | Groups on the first element of the tuple. This differs from the simple+-- @groupBy ((==) `on` fst)@ in that non-adjacent groups are __also__ grouped+-- together. For example:+--+-- @+-- groupFst = groupBy ((==) `on` fst)+--+-- let xs = [(1, "a"), (1, "b"), (3, "c"), (2, "d"), (3, "e"), (2, "f")]+--+-- groupFst xs === [[(1,"a"),(1,"b")],[(3,"c")],[(2,"d")],[(3,"e")],[(2,"f")]]+-- groupFstAll xs === [[(1,"a"),(1,"b")],[(3,"c"),(3,"e")],[(2,"d"),(2,"f")]]+-- @+--+-- Notice that the original order is preserved i.e. we do not first sort on+-- the first element.+--+-- @since 0.19.0.0+groupFstAll :: Ord a => [(a, b)] -> [[(a, b)]]+groupFstAll =+ -- In order to group all (adjacent + non-adjacent) Eq elements together, we+ -- sort the list so that the Eq elements are in fact adjacent, _then_ group.+ -- We don't want to destroy the original order, however, so we add a+ -- temporary index that maintains this original order. The full logic is:+ --+ -- 1. Add index i that preserves original order.+ -- 2. Sort on tuple's fst.+ -- 3. Group by fst.+ -- 4. Sort by i, restoring original order.+ -- 5. Drop index i.+ fmap (NE.toList . dropIdx)+ . List.sortOn toIdx+ . NE.groupBy ((==) `on` fst')+ . List.sortOn fst'+ . zipWithIndex+ where+ dropIdx :: NonEmpty (Int, (a, b)) -> NonEmpty (a, b)+ dropIdx = fmap snd -needsWrapping :: Wrapping -> Bool-needsWrapping = (==) Wrapped+ toIdx :: NonEmpty (Int, (a, b)) -> Int+ toIdx ((x, _) :| _) = x++ -- Like fst, ignores our added index+ fst' :: (Int, (a, b)) -> a+ fst' (_, (x, _)) = x++ zipWithIndex :: [(a, b)] -> [(Int, (a, b))]+ zipWithIndex = zip [1 ..]++-- | From base-4.19.0.0.+unsnoc :: [a] -> Maybe ([a], a)+unsnoc = foldr (\x -> Just . maybe ([], x) (\(~(a, b)) -> (x : a, b))) Nothing
src/Options/Applicative/Help/Levenshtein.hs view
@@ -14,25 +14,19 @@ -- Damerau-Levenshtein, which treats transposition -- of adjacent characters as one change instead of -- two.+--+-- Complexity+-- O(|a|*(1 + editDistance a b)) editDistance :: Eq a => [a] -> [a] -> Int-editDistance a b = 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)+editDistance a b =+ let+ mainDiag =+ oneDiag a b (head uppers) (-1 : head lowers)+ uppers =+ eachDiag a b (mainDiag : uppers) -- upper diagonals+ lowers =+ eachDiag b a (mainDiag : lowers) -- lower diagonals+ oneDiag a' b' diagAbove diagBelow = thisdiag where doDiag [] _ _ _ _ = []@@ -46,16 +40,40 @@ = 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+ let me =- if ach == bch- then nw- else 1 + min3 (head w) nw (head n)+ if ach == bch then+ nw+ else+ 1 + min3 (head w) nw (head n)+ in+ me : doDiag as bs me (tail n) (tail w)+ firstelt = 1 + head diagBelow thisdiag = firstelt : doDiag a' b' firstelt diagAbove (tail diagBelow)- lab = length a - length b++ eachDiag _ [] _ = []+ eachDiag _ _ [] = []+ eachDiag a' (_:bs) (lastDiag:diags) =+ let+ nextDiag = head (tail diags)+ in+ oneDiag a' bs nextDiag lastDiag : eachDiag a' bs diags++ lab =+ length a - length b+ min3 x y z =- if x < y- then x- else min y z+ if x < y then+ x+ else+ min y z++ in+ last $+ if lab == 0 then+ mainDiag+ else if lab > 0 then+ lowers !! (lab - 1)+ else+ uppers !! (-1 - lab)
src/Options/Applicative/Help/Pretty.hs view
@@ -1,34 +1,64 @@+{-# LANGUAGE CPP #-} module Options.Applicative.Help.Pretty- ( module Text.PrettyPrint.ANSI.Leijen+ ( module Prettyprinter+ , module Prettyprinter.Render.Terminal+ , Doc+ , SimpleDoc+ , (.$.)+ , (</>)+ , groupOrNestLine , altSep+ , hangAtIfOver++ , prettyString ) where -import Control.Applicative-import Data.Semigroup ((<>))+#if !MIN_VERSION_base(4,11,0)+import Data.Semigroup ((<>), mempty)+#endif+import qualified Data.Text.Lazy as Lazy -import Text.PrettyPrint.ANSI.Leijen hiding ((<$>), (<>), columns)-import Text.PrettyPrint.ANSI.Leijen.Internal (Doc (..), flatten)-import qualified Text.PrettyPrint.ANSI.Leijen as PP+import Prettyprinter hiding (Doc)+import qualified Prettyprinter as PP+import Prettyprinter.Render.Terminal import Prelude -(.$.) :: Doc -> Doc -> Doc-(.$.) = (PP.<$>)+type Doc = PP.Doc AnsiStyle+type SimpleDoc = SimpleDocStream AnsiStyle +linebreak :: Doc+linebreak = flatAlt line mempty +(.$.) :: Doc -> Doc -> Doc+x .$. y = x <> line <> y+(</>) :: Doc -> Doc -> Doc+x </> y = x <> softline <> y+ -- | Apply the function if we're not at the -- start of our nesting level. ifNotAtRoot :: (Doc -> Doc) -> Doc -> Doc-ifNotAtRoot f doc =- Nesting $ \i ->- Column $ \j ->- if i == j- then doc- else f doc+ifNotAtRoot =+ ifElseAtRoot id +-- | Apply the function if we're not at the+-- start of our nesting level.+ifAtRoot :: (Doc -> Doc) -> Doc -> Doc+ifAtRoot =+ flip ifElseAtRoot id +-- | Apply the function if we're not at the+-- start of our nesting level.+ifElseAtRoot :: (Doc -> Doc) -> (Doc -> Doc) -> Doc -> Doc+ifElseAtRoot f g doc =+ nesting $ \i ->+ column $ \j ->+ if i == j+ then f doc+ else g doc+ -- | Render flattened text on this line, or start -- a new line before rendering any text. --@@ -36,9 +66,7 @@ -- group. groupOrNestLine :: Doc -> Doc groupOrNestLine =- Union- <$> flatten- <*> ifNotAtRoot (line <>) . nest 2+ group . ifNotAtRoot (linebreak <>) . nest 2 -- | Separate items in an alternative with a pipe.@@ -53,4 +81,43 @@ -- next line. altSep :: Doc -> Doc -> Doc altSep x y =- group (x <+> char '|' <> line) <//> y+ group (x <+> pretty '|' <> line) <> group linebreak <> y+++-- | Printer hacks to get nice indentation for long commands+-- and subcommands.+--+-- If we're starting this section over the desired width+-- (usually 1/3 of the ribbon), then we will make a line+-- break, indent all of the usage, and go.+--+-- The ifAtRoot is an interesting clause. If this whole+-- operation is put under a `group` then the linebreak+-- will disappear; then item d will therefore not be at+-- the starting column, and it won't be indented more.+hangAtIfOver :: Int -> Int -> Doc -> Doc+hangAtIfOver i j d =+ column $ \k ->+ if k <= j then+ align d+ else+ linebreak <> ifAtRoot (indent i) d+++renderPretty :: Double -> Int -> Doc -> SimpleDocStream AnsiStyle+renderPretty ribbonFraction lineWidth+ = layoutPretty LayoutOptions+ { layoutPageWidth = AvailablePerLine lineWidth ribbonFraction }++prettyString :: Double -> Int -> Doc -> String+prettyString ribbonFraction lineWidth+ = streamToString+ . renderPretty ribbonFraction lineWidth++streamToString :: SimpleDocStream AnsiStyle -> String+streamToString sdoc =+ let+ rendered =+ Prettyprinter.Render.Terminal.renderLazy sdoc+ in+ Lazy.unpack rendered
src/Options/Applicative/Help/Types.hs view
@@ -14,28 +14,33 @@ , helpSuggestions :: Chunk Doc , helpHeader :: Chunk Doc , helpUsage :: Chunk Doc+ , helpDescription :: Chunk Doc , helpBody :: Chunk Doc- , helpFooter :: Chunk Doc }+ , helpGlobals :: Chunk Doc+ , helpFooter :: Chunk Doc+ } instance Show ParserHelp where showsPrec _ h = showString (renderHelp 80 h) instance Monoid ParserHelp where- mempty = ParserHelp mempty mempty mempty mempty mempty mempty+ mempty = ParserHelp mempty mempty 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 e1 s1 h1 u1 d1 b1 g1 f1) <> (ParserHelp e2 s2 h2 u2 d2 b2 g2 f2) = ParserHelp (mappend e1 e2) (mappend s1 s2) (mappend h1 h2) (mappend u1 u2)- (mappend b1 b2) (mappend f1 f2)+ (mappend d1 d2) (mappend b1 b2)+ (mappend g1 g2) (mappend f1 f2) helpText :: ParserHelp -> Doc-helpText (ParserHelp e s h u b f) = extractChunk . vsepChunks $ [e, s, h, u, b, f]+helpText (ParserHelp e s h u d b g f) =+ extractChunk $+ vsepChunks [e, s, h, u, fmap (indent 2) d, b, g, f] -- | Convert a help text to 'String'. renderHelp :: Int -> ParserHelp -> String renderHelp cols- = (`displayS` "")- . renderPretty 1.0 cols+ = prettyString 1.0 cols . helpText
src/Options/Applicative/Internal.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE RankNTypes #-}+ module Options.Applicative.Internal ( P , MonadP(..)@@ -18,11 +20,14 @@ , ListT , takeListT , runListT+ , hoistList , NondetT , cut , (<!>) , disamb++ , mapParserOptions ) where import Control.Applicative@@ -35,6 +40,7 @@ (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@@ -172,9 +178,6 @@ 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@@ -192,7 +195,7 @@ . stepListT instance Monad m => Applicative (ListT m) where- pure = hoistList . pure+ pure a = ListT (return (TCons a mzero)) (<*>) = ap instance Monad m => Monad (ListT m) where@@ -263,3 +266,21 @@ return $ case xs' of [x] -> Just x _ -> Nothing++hoistList :: Alternative m => [a] -> m a+hoistList = foldr cons empty+ where+ cons x xs = pure x <|> xs++-- | Maps an Option modifying function over the Parser.+--+-- @since 0.19.0.0+mapParserOptions :: (forall x. Option x -> Option x) -> Parser a -> Parser a+mapParserOptions f = go+ where+ go :: forall y. Parser y -> Parser y+ go (NilP x) = NilP x+ go (OptP o) = OptP (f o)+ go (MultP p1 p2) = MultP (go p1) (go p2)+ go (AltP p1 p2) = AltP (go p1) (go p2)+ go (BindP p1 p2) = BindP (go p1) (\x -> go (p2 x))
+ src/Options/Applicative/NonEmpty.hs view
@@ -0,0 +1,16 @@+module Options.Applicative.NonEmpty (+ some1+) where++import Data.List.NonEmpty (NonEmpty (..))++import Options.Applicative.Types+import Control.Applicative+import Prelude++-- | Sequences an action one or more times.+--+-- Functionally identical to 'Data.List.NonEmpty.some1',+-- but is preferred as it gives a nicer help text.+some1 :: Parser a -> Parser (NonEmpty a)+some1 p = fromM $ (:|) <$> oneM p <*> manyM p
src/Options/Applicative/Types.hs view
@@ -11,6 +11,7 @@ OptReader(..), OptProperties(..),+ OptGroup(..), OptVisibility(..), Backtracking(..), ReadM(..),@@ -28,7 +29,7 @@ overFailure, Args, ArgPolicy(..),- OptHelpInfo(..),+ ArgumentReachability(..), AltNodeType(..), OptTree(..), ParserHelp(..),@@ -68,7 +69,7 @@ data ParseError = ErrorMsg String | InfoMsg String- | ShowHelpText+ | ShowHelpText (Maybe String) | UnknownError | MissingError IsCmdStart SomeParser | ExpectsArgError String@@ -123,6 +124,11 @@ , prefHelpLongEquals :: Bool -- ^ when displaying long names in usage and help, -- use an '=' sign for long names, rather than a -- single space (default: False)+ , prefHelpShowGlobal :: Bool -- ^ when displaying subparsers' usage help,+ -- show parent options under a "global options"+ -- section (default: False)+ , prefTabulateFill ::Int -- ^ Indentation width for tables+ , prefBriefHangPoint :: Int -- ^ Width at which to hang the brief description } deriving (Eq, Show) data OptName = OptShort !Char@@ -143,23 +149,37 @@ | Visible -- ^ visible both in the full and brief descriptions deriving (Eq, Ord, Show) +-- | Groups for optionals. Can be multiple in the case of nested groups.+--+-- @since 0.19.0.0+newtype OptGroup = OptGroup [String]+ deriving (Eq, Ord, Show)+ -- | Specification for an individual parser option. data OptProperties = OptProperties { propVisibility :: OptVisibility -- ^ whether this flag is shown in the brief description , propHelp :: Chunk Doc -- ^ help text for this option , propMetaVar :: String -- ^ metavariable for this option , propShowDefault :: Maybe String -- ^ what to show in the help text as the default+ , propShowGlobal :: Bool -- ^ whether the option is presented in global options text , propDescMod :: Maybe ( Doc -> Doc ) -- ^ a function to run over the brief description+ , propGroup :: OptGroup+ -- ^ optional group(s)+ --+ -- @since 0.19.0.0 } instance Show OptProperties where- showsPrec p (OptProperties pV pH pMV pSD _)+ showsPrec p (OptProperties pV pH pMV pSD pSG _ pGrp) = showParen (p >= 11) $ showString "OptProperties { propVisibility = " . shows pV . showString ", propHelp = " . shows pH . showString ", propMetaVar = " . shows pMV . showString ", propShowDefault = " . shows pSD- . showString ", propDescMod = _ }"+ . showString ", propShowGlobal = " . shows pSG+ . showString ", propDescMod = _"+ . showString ", propGroup = " . shows pGrp+ . showString "}" -- | A single option of a parser. data Option a = Option@@ -169,9 +189,10 @@ 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)+-- | Subparser context, containing the name of the subparser and its parser info.+-- Used by 'Options.Applicative.Extra.parserFailure' to display relevant usage+-- information when parsing inside a subparser fails.+data Context = forall a. Context String (ParserInfo a) instance Show (Option a) where show opt = "Option {optProps = " ++ show (optProps opt) ++ "}"@@ -236,16 +257,16 @@ -- ^ flag reader | ArgReader (CReader a) -- ^ argument reader- | CmdReader (Maybe String) [String] (String -> Maybe (ParserInfo a))+ | CmdReader (Maybe String) [(String, ParserInfo a)] -- ^ command reader instance Functor OptReader where fmap f (OptReader ns cr e) = OptReader ns (fmap f cr) e fmap f (FlagReader ns x) = FlagReader ns (f x) fmap f (ArgReader cr) = ArgReader (fmap f cr)- fmap f (CmdReader n cs g) = CmdReader n cs ((fmap . fmap) f . g)+ fmap f (CmdReader n cs) = CmdReader n ((fmap . fmap . fmap) f cs) --- | A @Parser a@ is an option parser returning a value of type 'a'.+-- | A @Parser a@ is an option parser returning a value of type @a@. data Parser a = NilP (Maybe a) | OptP (Option a)@@ -297,8 +318,8 @@ instance Alternative Parser where empty = NilP Nothing (<|>) = AltP- many p = fromM $ manyM p- some p = fromM $ (:) <$> oneM p <*> manyM p+ many = fromM . manyM+ some = fromM . someM -- | A shell complete function. newtype Completer = Completer@@ -329,14 +350,14 @@ instance Show h => Show (ParserFailure h) where showsPrec p (ParserFailure f) = showParen (p > 10)- $ showString "ParserFailure "+ $ 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'.+-- | Result of 'Options.Applicative.execParserPure'. data ParserResult a = Success a | Failure (ParserFailure ParserHelp)@@ -392,10 +413,9 @@ -- 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 )+newtype ArgumentReachability = ArgumentReachability+ { argumentIsUnreachable :: Bool -- ^ If the result is a positional, if it can't be+ -- accessed in the current parser position ( first arg ) } deriving (Eq, Show) -- | This type encapsulates whether an 'AltNode' of an 'OptTree' should be displayed@@ -407,6 +427,7 @@ = Leaf a | MultNode [OptTree a] | AltNode AltNodeType [OptTree a]+ | BindNode (OptTree a) deriving Show filterOptional :: OptTree a -> OptTree a@@ -419,6 +440,8 @@ -> AltNode MarkDefault [] AltNode NoDefault xs -> AltNode NoDefault (map filterOptional xs)+ BindNode xs+ -> BindNode (filterOptional xs) optVisibility :: Option a -> OptVisibility optVisibility = propVisibility . optProps
tests/Examples/Cabal.hs view
@@ -39,10 +39,6 @@ { buildDir :: FilePath } deriving Show -version :: Parser (a -> a)-version = infoOption "0.0.0"- ( long "version"- <> help "Print version information" ) parser :: Parser Args parser = runA $ proc () -> do@@ -60,7 +56,7 @@ <> command "build" (info buildParser (progDesc "Make this package ready for installation")) ) -< ()- A version >>> A helper -< Args opts cmds+ A (simpleVersioner "0.0.0") >>> A helper -< Args opts cmds commonOpts :: Parser CommonOpts commonOpts = CommonOpts@@ -124,5 +120,5 @@ main :: IO () main = do- r <- execParser pinfo+ r <- customExecParser (prefs helpShowGlobals) pinfo print r
+ tests/Examples/LongSub.hs view
@@ -0,0 +1,34 @@+{-# LANGUAGE CPP #-}+module Examples.LongSub where++import Data.Monoid+import Options.Applicative++#if __GLASGOW_HASKELL__ <= 702+(<>) :: Monoid a => a -> a -> a+(<>) = mappend+#endif++data Sample+ = Hello [String]+ | Goodbye+ deriving (Eq, Show)++hello :: Parser Sample+hello =+ Hello+ <$> many (argument str (metavar "TARGET..."))+ <* switch (long "first-flag")+ <* switch (long "second-flag")+ <* switch (long "third-flag")+ <* switch (long "fourth-flag")++sample :: Parser Sample+sample = hsubparser+ ( command "hello-very-long-sub"+ (info hello+ (progDesc "Print greeting"))+ )++opts :: ParserInfo Sample+opts = info (sample <**> helper) idm
+ tests/Examples/ParserGroup/AllGrouped.hs view
@@ -0,0 +1,91 @@+{-# LANGUAGE NamedFieldPuns #-}++module Examples.ParserGroup.AllGrouped (opts, main) where++import Data.Semigroup ((<>))+import Options.Applicative++-- Tests the help page when every option belongs to some group i.e. there are+-- no top-level options. Notice we put the helper (<**> helper) __inside__+-- one of the groups, so that it is not a top-level option.+--+-- Also notice that although we add cmdParser to the same group, it is __not__+-- rendered as part of this group. This is what we want, as it is an Argument+-- and should not be rendered with the Options.++data LogGroup = LogGroup+ { logPath :: Maybe String,+ logVerbosity :: Maybe Int+ }+ deriving (Show)++data SystemGroup = SystemGroup+ { poll :: Bool,+ timeout :: Int+ }+ deriving (Show)++data Sample = Sample+ { logGroup :: LogGroup,+ systemGroup :: SystemGroup,+ cmd :: String+ }+ deriving (Show)++sample :: Parser Sample+sample =+ Sample+ <$> parseLogGroup+ <*> parseSystemGroup+ <*> parseCmd++ where+ parseLogGroup =+ parserOptionGroup "Logging" $+ LogGroup+ <$> optional+ ( strOption+ ( long "file-log-path"+ <> metavar "PATH"+ <> help "Log file path"+ )+ )+ <*> optional+ ( option+ auto+ ( long "file-log-verbosity"+ <> metavar "INT"+ <> help "File log verbosity"+ )+ )+ <**> helper++ parseSystemGroup =+ parserOptionGroup "System Options" $+ SystemGroup+ <$> switch+ ( long "poll"+ <> help "Whether to poll"+ )+ <*> option+ auto+ ( long "timeout"+ <> metavar "INT"+ <> help "Whether to time out"+ )++ parseCmd = argument str (metavar "Command")++opts :: ParserInfo Sample+opts =+ info+ sample+ ( fullDesc+ <> progDesc "Every option is grouped"+ <> header "parser_group.all_grouped - a test for optparse-applicative"+ )++main :: IO ()+main = do+ r <- customExecParser (prefs helpShowGlobals) opts+ print r
+ tests/Examples/ParserGroup/Basic.hs view
@@ -0,0 +1,111 @@+{-# LANGUAGE NamedFieldPuns #-}++module Examples.ParserGroup.Basic (opts, main) where++import Data.Semigroup ((<>))+import Options.Applicative++data LogGroup = LogGroup+ { logPath :: Maybe String,+ logVerbosity :: Maybe Int+ }+ deriving (Show)++data SystemGroup = SystemGroup+ { poll :: Bool,+ timeout :: Int+ }+ deriving (Show)++data Sample = Sample+ { hello :: String,+ logGroup :: LogGroup,+ quiet :: Bool,+ systemGroup :: SystemGroup,+ verbosity :: Int,+ cmd :: String+ }+ deriving (Show)++sample :: Parser Sample+sample =+ Sample+ <$> parseHello+ <*> parseLogGroup+ <*> parseQuiet+ <*> parseSystemGroup+ <*> parseVerbosity+ <*> parseCmd++ where+ parseHello =+ strOption+ ( long "hello"+ <> metavar "TARGET"+ <> help "Target for the greeting"+ )++ parseLogGroup =+ parserOptionGroup "Logging" $+ LogGroup+ <$> optional+ ( strOption+ ( long "file-log-path"+ <> metavar "PATH"+ <> help "Log file path"+ )+ )+ <*> optional+ ( option+ auto+ ( long "file-log-verbosity"+ <> metavar "INT"+ <> help "File log verbosity"+ )+ )++ parseQuiet =+ switch+ ( long "quiet"+ <> short 'q'+ <> help "Whether to be quiet"+ )++ parseSystemGroup =+ parserOptionGroup "System Options" $+ SystemGroup+ <$> switch+ ( long "poll"+ <> help "Whether to poll"+ )+ <*> ( option+ auto+ ( long "timeout"+ <> metavar "INT"+ <> help "Whether to time out"+ )+ )++ parseVerbosity =+ option+ auto+ ( long "verbosity"+ <> short 'v'+ <> help "Console verbosity"+ )++ parseCmd = argument str (metavar "Command")++opts :: ParserInfo Sample+opts =+ info+ (sample <**> helper)+ ( fullDesc+ <> progDesc "Shows parser groups"+ <> header "parser_group.basic - a test for optparse-applicative"+ )++main :: IO ()+main = do+ r <- customExecParser (prefs helpShowGlobals) opts+ print r
+ tests/Examples/ParserGroup/CommandGroups.hs view
@@ -0,0 +1,134 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}++module Examples.ParserGroup.CommandGroups (opts, main) where++import Data.Semigroup ((<>))+import Options.Applicative++data LogGroup = LogGroup+ { logPath :: Maybe String,+ logVerbosity :: Maybe Int+ }+ deriving (Show)++data SystemGroup = SystemGroup+ { poll :: Bool,+ timeout :: Int+ }+ deriving (Show)++data Command+ = Delete+ | List+ | Print+ | Query+ deriving (Show)++data Sample = Sample+ { hello :: String,+ logGroup :: LogGroup,+ quiet :: Bool,+ systemGroup :: SystemGroup,+ verbosity :: Int,+ cmd :: Command+ }+ deriving (Show)++sample :: Parser Sample+sample =+ Sample+ <$> parseHello+ <*> parseLogGroup+ <*> parseQuiet+ <*> parseSystemGroup+ <*> parseVerbosity+ <*> parseCommand++ where+ parseHello =+ strOption+ ( long "hello"+ <> metavar "TARGET"+ <> help "Target for the greeting"+ )++ parseLogGroup =+ parserOptionGroup "Logging" $+ LogGroup+ <$> optional+ ( strOption+ ( long "file-log-path"+ <> metavar "PATH"+ <> help "Log file path"+ )+ )+ <*> optional+ ( option+ auto+ ( long "file-log-verbosity"+ <> metavar "INT"+ <> help "File log verbosity"+ )+ )++ parseQuiet =+ switch+ ( long "quiet"+ <> short 'q'+ <> help "Whether to be quiet"+ )++ parseSystemGroup =+ parserOptionGroup "System Options" $+ SystemGroup+ <$> switch+ ( long "poll"+ <> help "Whether to poll"+ )+ <*> ( option+ auto+ ( long "timeout"+ <> metavar "INT"+ <> help "Whether to time out"+ )+ )++ parseVerbosity =+ option+ auto+ ( long "verbosity"+ <> short 'v'+ <> help "Console verbosity"+ )++ parseCommand =+ hsubparser+ ( command "list 2" (info (pure List) $ progDesc "Lists elements")+ )+ <|> hsubparser+ ( command "list" (info (pure List) $ progDesc "Lists elements")+ <> command "print" (info (pure Print) $ progDesc "Prints table")+ <> commandGroup "Info commands"+ )+ <|> hsubparser+ ( command "delete" (info (pure Delete) $ progDesc "Deletes elements")+ )+ <|> hsubparser+ ( command "query" (info (pure Query) $ progDesc "Runs a query")+ <> commandGroup "Query commands"+ )++opts :: ParserInfo Sample+opts =+ info+ (sample <**> helper)+ ( fullDesc+ <> progDesc "Option and command groups"+ <> header "parser_group.command_groups - a test for optparse-applicative"+ )++main :: IO ()+main = do+ r <- customExecParser (prefs helpShowGlobals) opts+ print r
+ tests/Examples/ParserGroup/DuplicateCommandGroups.hs view
@@ -0,0 +1,92 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}++module Examples.ParserGroup.DuplicateCommandGroups (opts, main) where++import Data.Semigroup ((<>))+import Options.Applicative++-- This test demonstrates that duplicate + consecutive groups are merged,+-- while duplicate + non-consecutive groups are not merged.++data Command+ = Delete+ | Insert+ | List+ | Print+ | Query+ deriving (Show)++data Sample = Sample+ { hello :: String,+ quiet :: Bool,+ verbosity :: Int,+ cmd :: Command+ }+ deriving (Show)++sample :: Parser Sample+sample =+ Sample+ <$> parseHello+ <*> parseQuiet+ <*> parseVerbosity+ <*> parseCommand++ where+ parseHello =+ strOption+ ( long "hello"+ <> metavar "TARGET"+ <> help "Target for the greeting"+ )++ parseQuiet =+ switch+ ( long "quiet"+ <> short 'q'+ <> help "Whether to be quiet"+ )++ parseVerbosity =+ option+ auto+ ( long "verbosity"+ <> short 'v'+ <> help "Console verbosity"+ )++ parseCommand =+ hsubparser+ ( command "list" (info (pure List) $ progDesc "Lists elements")+ <> commandGroup "Info commands"+ )+ <|> hsubparser+ ( command "delete" (info (pure Delete) $ progDesc "Deletes elements")+ <> commandGroup "Update commands"+ )+ <|> hsubparser+ ( command "insert" (info (pure Insert) $ progDesc "Inserts elements")+ <> commandGroup "Update commands"+ )+ <|> hsubparser+ ( command "query" (info (pure Query) $ progDesc "Runs a query")+ )+ <|> hsubparser+ ( command "print" (info (pure Print) $ progDesc "Prints table")+ <> commandGroup "Info commands"+ )++opts :: ParserInfo Sample+opts =+ info+ (sample <**> helper)+ ( fullDesc+ <> progDesc "Duplicate consecutive command groups consolidated"+ <> header "parser_group.duplicate_command_groups - a test for optparse-applicative"+ )++main :: IO ()+main = do+ r <- customExecParser (prefs helpShowGlobals) opts+ print r
+ tests/Examples/ParserGroup/Duplicates.hs view
@@ -0,0 +1,153 @@+{-# LANGUAGE NamedFieldPuns #-}++module Examples.ParserGroup.Duplicates (opts, main) where++import Data.Semigroup ((<>))+import Options.Applicative++-- NOTE: This is the same structure as ParserGroup.Basic __except__+-- we have two (non-consecutive) "Logging" groups and two (consecutive)+-- System groups. This test demonstrates two things:+--+-- 1. Non-consecutive groups are not merged (i.e. we display two "Logging"+-- sections).+-- 2. Consecutive groups are merged (i.e. we display only one "System" group).+--+-- This is like command groups.++data LogGroup1 = LogGroup1+ { logPath :: Maybe String,+ logVerbosity :: Maybe Int+ }+ deriving (Show)++data LogGroup2 = LogGroup2+ { logNamespace :: String+ }+ deriving (Show)++data SystemGroup1 = SystemGroup1+ { poll :: Bool,+ timeout :: Int+ }+ deriving (Show)++newtype SystemGroup2 = SystemGroup2+ { sysFlag :: Bool+ }+ deriving (Show)++data Sample = Sample+ { hello :: String,+ logGroup1 :: LogGroup1,+ quiet :: Bool,+ systemGroup1 :: SystemGroup1,+ systemGroup2 :: SystemGroup2,+ logGroup2 :: LogGroup2,+ verbosity :: Int,+ cmd :: String+ }+ deriving (Show)++sample :: Parser Sample+sample =+ Sample+ <$> parseHello+ <*> parseLogGroup1+ <*> parseQuiet+ <*> parseSystemGroup1+ <*> parseSystemGroup2+ <*> parseLogGroup2+ <*> parseVerbosity+ <*> parseCmd++ where+ parseHello =+ strOption+ ( long "hello"+ <> metavar "TARGET"+ <> help "Target for the greeting"+ )++ parseLogGroup1 =+ parserOptionGroup "Logging" $+ LogGroup1+ <$> optional+ ( strOption+ ( long "file-log-path"+ <> metavar "PATH"+ <> help "Log file path"+ )+ )+ <*> optional+ ( option+ auto+ ( long "file-log-verbosity"+ <> metavar "INT"+ <> help "File log verbosity"+ )+ )++ parseQuiet =+ switch+ ( long "quiet"+ <> short 'q'+ <> help "Whether to be quiet"+ )++ parseSystemGroup1 =+ parserOptionGroup "System" $+ SystemGroup1+ <$> switch+ ( long "poll"+ <> help "Whether to poll"+ )+ <*> option+ auto+ ( long "timeout"+ <> metavar "INT"+ <> help "Whether to time out"+ )++ parseSystemGroup2 =+ parserOptionGroup "System" $+ SystemGroup2+ <$> switch+ ( long "sysFlag"+ <> help "Some flag"+ )++ parseLogGroup2 =+ parserOptionGroup "Logging" $+ LogGroup2+ <$>+ strOption+ ( long "log-namespace"+ <> metavar "STR"+ <> help "Log namespace"+ )++ parseVerbosity =+ option+ auto+ ( long "verbosity"+ <> short 'v'+ <> help "Console verbosity"+ )++ parseCmd = argument str (metavar "Command")++opts :: ParserInfo Sample+opts =+ info+ (sample <**> helper)+ ( fullDesc+ <> progDesc "Duplicate consecutive groups consolidated"+ <> header "parser_group.duplicates - a test for optparse-applicative"+ )++main :: IO ()+main = do+ r <- customExecParser (prefs helpShowGlobals) opts+ print r+
+ tests/Examples/ParserGroup/Nested.hs view
@@ -0,0 +1,139 @@+{-# LANGUAGE NamedFieldPuns #-}++module Examples.ParserGroup.Nested (opts, main) where++import Data.Semigroup ((<>))+import Options.Applicative++-- Nested groups. Demonstrates that group can nest.++data LogGroup = LogGroup+ { logPath :: Maybe String,+ systemGroup :: SystemGroup,+ logVerbosity :: Maybe Int+ }+ deriving (Show)++data SystemGroup = SystemGroup+ { poll :: Bool,+ deepNested :: Nested2,+ timeout :: Int+ }+ deriving (Show)++data Nested2 = Nested2+ { nested2Str :: String,+ nested3 :: Nested3+ }+ deriving (Show)++newtype Nested3 = Nested3+ { nested3Str :: String+ }+ deriving (Show)++data Sample = Sample+ { hello :: String,+ logGroup :: LogGroup,+ quiet :: Bool,+ verbosity :: Int,+ group2 :: (Int, Int),+ cmd :: String+ }+ deriving (Show)++sample :: Parser Sample+sample =+ Sample+ <$> parseHello+ <*> parseLogGroup+ <*> parseQuiet+ <*> parseVerbosity+ <*> parseGroup2+ <*> parseCmd++ where+ parseHello =+ strOption+ ( long "hello"+ <> metavar "TARGET"+ <> help "Target for the greeting"+ )++ parseLogGroup =+ parserOptionGroup "First group" $+ parserOptionGroup "Second group" $+ parserOptionGroup "Logging" $+ LogGroup+ <$> parseLogPath+ <*> parseSystemGroup+ <*> parseLogVerbosity++ where+ parseLogPath =+ optional+ ( strOption+ ( long "file-log-path"+ <> metavar "PATH"+ <> help "Log file path"+ )+ )+ parseLogVerbosity =+ optional+ ( option+ auto+ ( long "file-log-verbosity"+ <> metavar "INT"+ <> help "File log verbosity"+ )+ )++ parseQuiet =+ switch+ ( long "quiet"+ <> short 'q'+ <> help "Whether to be quiet"+ )++ parseSystemGroup =+ parserOptionGroup "System Options" $+ SystemGroup+ <$> switch (long "poll" <> help "Whether to poll")+ <*> parseNested2+ <*> option auto (long "timeout" <> metavar "INT" <> help "Whether to time out")++ parseNested2 =+ parserOptionGroup "Nested2" $+ Nested2+ <$> option auto (long "double-nested" <> metavar "STR" <> help "Some nested option")+ <*> parseNested3++ parseNested3 =+ parserOptionGroup "Nested3" $+ Nested3 <$> option auto (long "triple-nested" <> metavar "STR" <> help "Another option")++ parseGroup2 :: Parser (Int, Int)+ parseGroup2 = parserOptionGroup "Group 2" $+ (,)+ <$> parserOptionGroup "G 2.1" (option auto (long "one" <> help "Option 1"))+ <*> parserOptionGroup "G 2.2" (option auto (long "two" <> help "Option 2"))++ parseVerbosity =+ option auto (long "verbosity" <> short 'v' <> help "Console verbosity")++ parseCmd =+ argument str (metavar "Command")++opts :: ParserInfo Sample+opts =+ info+ (sample <**> helper)+ ( fullDesc+ <> progDesc "Nested parser groups"+ <> header "parser_group.nested - a test for optparse-applicative"+ )++main :: IO ()+main = do+ r <- customExecParser (prefs helpShowGlobals) opts+ print r
tests/cabal.err.txt view
@@ -1,7 +1,12 @@ Usage: cabal configure [--enable-tests] [-f|--flags FLAGS]+ Prepare to build the package Available options: --enable-tests Enable compilation of test suites -f,--flags FLAGS Enable the given flag -h,--help Show this help text++Global options:+ -v,--verbose LEVEL Set verbosity to LEVEL+ --version Show version information
+ tests/formatting-long-subcommand.err.txt view
@@ -0,0 +1,9 @@+Usage: formatting-long-subcommand hello-very-long-sub + [TARGET...] [--first-flag] + [--second-flag] [--third-flag] + [--fourth-flag]++ Print greeting++Available options:+ -h,--help Show this help text
tests/formatting.err.txt view
@@ -1,4 +1,5 @@ Usage: formatting [-t|--test FOO_BAR_BAZ_LONG_METAVARIABLE]+ This is a very long program description. This text should be automatically wrapped to fit the size of the terminal
tests/hello.err.txt view
@@ -1,6 +1,7 @@ hello - a test for optparse-applicative Usage: hello --hello TARGET [-q|--quiet] [--repeat INT]+ Print a greeting for TARGET Available options:
+ tests/parser_group_all_grouped.err.txt view
@@ -0,0 +1,16 @@+parser_group.all_grouped - a test for optparse-applicative++Usage: parser_group_all_grouped [--file-log-path PATH] + [--file-log-verbosity INT] [--poll]+ --timeout INT Command++ Every option is grouped++Logging+ --file-log-path PATH Log file path+ --file-log-verbosity INT File log verbosity+ -h,--help Show this help text++System Options+ --poll Whether to poll+ --timeout INT Whether to time out
+ tests/parser_group_basic.err.txt view
@@ -0,0 +1,21 @@+parser_group.basic - a test for optparse-applicative++Usage: parser_group_basic --hello TARGET [--file-log-path PATH] + [--file-log-verbosity INT] [-q|--quiet] [--poll]+ --timeout INT (-v|--verbosity ARG) Command++ Shows parser groups++Available options:+ --hello TARGET Target for the greeting+ -q,--quiet Whether to be quiet+ -v,--verbosity ARG Console verbosity+ -h,--help Show this help text++Logging+ --file-log-path PATH Log file path+ --file-log-verbosity INT File log verbosity++System Options+ --poll Whether to poll+ --timeout INT Whether to time out
+ tests/parser_group_command_groups.err.txt view
@@ -0,0 +1,33 @@+parser_group.command_groups - a test for optparse-applicative++Usage: parser_group_command_groups --hello TARGET [--file-log-path PATH] + [--file-log-verbosity INT] [-q|--quiet] + [--poll] --timeout INT (-v|--verbosity ARG) + (COMMAND | COMMAND | COMMAND | COMMAND)++ Option and command groups++Available options:+ --hello TARGET Target for the greeting+ -q,--quiet Whether to be quiet+ -v,--verbosity ARG Console verbosity+ -h,--help Show this help text++Logging+ --file-log-path PATH Log file path+ --file-log-verbosity INT File log verbosity++System Options+ --poll Whether to poll+ --timeout INT Whether to time out++Available commands:+ list 2 Lists elements+ delete Deletes elements++Info commands+ list Lists elements+ print Prints table++Query commands+ query Runs a query
+ tests/parser_group_duplicate_command_groups.err.txt view
@@ -0,0 +1,24 @@+parser_group.duplicate_command_groups - a test for optparse-applicative++Usage: parser_group_duplicate_command_groups + --hello TARGET [-q|--quiet] (-v|--verbosity ARG) + (COMMAND | COMMAND | COMMAND | COMMAND | COMMAND)++ Duplicate consecutive command groups consolidated++Available options:+ --hello TARGET Target for the greeting+ -q,--quiet Whether to be quiet+ -v,--verbosity ARG Console verbosity+ -h,--help Show this help text++Available commands:+ query Runs a query++Info commands+ list Lists elements+ print Prints table++Update commands+ delete Deletes elements+ insert Inserts elements
+ tests/parser_group_duplicates.err.txt view
@@ -0,0 +1,24 @@+parser_group.duplicates - a test for optparse-applicative++Usage: parser_group_duplicates --hello TARGET [--file-log-path PATH] + [--file-log-verbosity INT] [-q|--quiet] [--poll]+ --timeout INT [--sysFlag] --log-namespace STR+ (-v|--verbosity ARG) Command++ Duplicate consecutive groups consolidated++Available options:+ --hello TARGET Target for the greeting+ -q,--quiet Whether to be quiet+ -v,--verbosity ARG Console verbosity+ -h,--help Show this help text++Logging+ --file-log-path PATH Log file path+ --file-log-verbosity INT File log verbosity+ --log-namespace STR Log namespace++System+ --poll Whether to poll+ --timeout INT Whether to time out+ --sysFlag Some flag
+ tests/parser_group_nested.err.txt view
@@ -0,0 +1,37 @@+parser_group.nested - a test for optparse-applicative++Usage: parser_group_nested --hello TARGET [--file-log-path PATH] [--poll]+ --double-nested STR --triple-nested STR --timeout INT+ [--file-log-verbosity INT] [-q|--quiet]+ (-v|--verbosity ARG) --one ARG --two ARG Command++ Nested parser groups++Available options:+ --hello TARGET Target for the greeting+ -q,--quiet Whether to be quiet+ -v,--verbosity ARG Console verbosity+ -h,--help Show this help text++First group+- Second group+ - Logging+ --file-log-path PATH Log file path+ --file-log-verbosity INT File log verbosity++ - System Options+ --poll Whether to poll+ --timeout INT Whether to time out++ - Nested2+ --double-nested STR Some nested option++ - Nested3+ --triple-nested STR Another option++Group 2+- G 2.1+ --one ARG Option 1++- G 2.2+ --two ARG Option 2
tests/test.hs view
@@ -9,12 +9,19 @@ import qualified Examples.Cabal as Cabal import qualified Examples.Alternatives as Alternatives import qualified Examples.Formatting as Formatting+import qualified Examples.LongSub as LongSub+import qualified Examples.ParserGroup.AllGrouped as ParserGroup.AllGrouped+import qualified Examples.ParserGroup.Basic as ParserGroup.Basic+import qualified Examples.ParserGroup.CommandGroups as ParserGroup.CommandGroups+import qualified Examples.ParserGroup.DuplicateCommandGroups as ParserGroup.DuplicateCommandGroups+import qualified Examples.ParserGroup.Duplicates as ParserGroup.Duplicates+import qualified Examples.ParserGroup.Nested as ParserGroup.Nested import Control.Applicative import Control.Monad-import Data.ByteString (ByteString)-import qualified Data.ByteString.Char8 as BS8+import Data.Function (on) import Data.List hiding (group)+import Data.List.NonEmpty (NonEmpty ((:|))) import Data.Semigroup hiding (option) import Data.String @@ -24,7 +31,11 @@ import Options.Applicative import Options.Applicative.Types-import Options.Applicative.Help.Pretty (Doc, SimpleDoc(..))+import qualified Options.Applicative.NonEmpty+++import qualified Options.Applicative.Help as H+import Options.Applicative.Help.Pretty (Doc) import qualified Options.Applicative.Help.Pretty as Doc import Options.Applicative.Help.Chunk import Options.Applicative.Help.Levenshtein@@ -84,7 +95,7 @@ prop_cabal_conf :: Property prop_cabal_conf = once $- checkHelpText "cabal" Cabal.pinfo ["configure", "--help"]+ checkHelpTextWith ExitSuccess (prefs helpShowGlobals) "cabal" Cabal.pinfo ["configure", "--help"] prop_args :: Property prop_args = once $@@ -314,6 +325,49 @@ result = execParserPure (prefs disambiguate) i ["--ba"] in assertError result (\_ -> property succeeded) ++prop_disambiguate_in_same_subparsers :: Property+prop_disambiguate_in_same_subparsers = once $+ let p0 = subparser (command "oranges" (info (pure "oranges") idm) <> command "apples" (info (pure "apples") idm) <> metavar "B")+ i = info (p0 <**> helper) idm+ result = execParserPure (prefs disambiguate) i ["orang"]+ in assertResult result ((===) "oranges")++prop_disambiguate_commands_in_separate_subparsers :: Property+prop_disambiguate_commands_in_separate_subparsers = once $+ let p2 = subparser (command "oranges" (info (pure "oranges") idm) <> metavar "B")+ p1 = subparser (command "apples" (info (pure "apples") idm) <> metavar "C")+ p0 = p1 <|> p2+ i = info (p0 <**> helper) idm+ result = execParserPure (prefs disambiguate) i ["orang"]+ in assertResult result ((===) "oranges")++prop_fail_ambiguous_commands_in_same_subparser :: Property+prop_fail_ambiguous_commands_in_same_subparser = once $+ let p0 = subparser (command "oranges" (info (pure ()) idm) <> command "orangutans" (info (pure ()) idm) <> metavar "B")+ i = info (p0 <**> helper) idm+ result = execParserPure (prefs disambiguate) i ["orang"]+ in assertError result (\_ -> property succeeded)++prop_fail_ambiguous_commands_in_separate_subparser :: Property+prop_fail_ambiguous_commands_in_separate_subparser = once $+ let p2 = subparser (command "oranges" (info (pure ()) idm) <> metavar "B")+ p1 = subparser (command "orangutans" (info (pure ()) idm) <> metavar "C")+ p0 = p1 <|> p2+ i = info (p0 <**> helper) idm+ result = execParserPure (prefs disambiguate) i ["orang"]+ in assertError result (\_ -> property succeeded)++prop_without_disambiguation_same_named_commands_should_parse_in_order :: Property+prop_without_disambiguation_same_named_commands_should_parse_in_order = once $+ let p3 = subparser (command "b" (info (pure ()) idm) <> metavar "B")+ p2 = subparser (command "a" (info (pure ()) idm) <> metavar "B")+ p1 = subparser (command "a" (info (pure ()) idm) <> metavar "C")+ p0 = (,,) <$> p1 <*> p2 <*> p3+ i = info (p0 <**> helper) idm+ result = execParserPure defaultPrefs i ["b", "a", "a"]+ in assertResult result ((===) ((), (), ()))+ prop_completion :: Property prop_completion = once . ioProperty $ let p = (,)@@ -763,25 +817,175 @@ in counterexample msg $ isInfixOf "Did you mean one of these?\n first\n fst" msg -prop_bytestring_reader :: Property-prop_bytestring_reader = once $- let t = "testValue"- p :: Parser ByteString- p = argument str idm+prop_grouped_some_option_ellipsis :: Property+prop_grouped_some_option_ellipsis = once $+ let x :: Parser String+ x = strOption (short 'x' <> metavar "X")+ p = prefs (multiSuffix "...")+ r = show . extractChunk $ H.briefDesc p (x *> some x)+ in r === "-x X (-x X)..."++prop_grouped_many_option_ellipsis :: Property+prop_grouped_many_option_ellipsis = once $+ let x :: Parser String+ x = strOption (short 'x' <> metavar "X")+ p = prefs (multiSuffix "...")+ r = show . extractChunk $ H.briefDesc p (x *> many x)+ in r === "-x X [-x X]..."++prop_grouped_some_argument_ellipsis :: Property+prop_grouped_some_argument_ellipsis = once $+ let x :: Parser String+ x = strArgument (metavar "X")+ p = prefs (multiSuffix "...")+ r = show . extractChunk $ H.briefDesc p (x *> some x)+ in r === "X X..."++prop_grouped_many_argument_ellipsis :: Property+prop_grouped_many_argument_ellipsis = once $+ let x :: Parser String+ x = strArgument (metavar "X")+ p = prefs (multiSuffix "...")+ r = show . extractChunk $ H.briefDesc p (x *> many x)+ in r === "X [X]..."++prop_grouped_some_pairs_argument_ellipsis :: Property+prop_grouped_some_pairs_argument_ellipsis = once $+ let x :: Parser String+ x = strArgument (metavar "X")+ p = prefs (multiSuffix "...")+ r = show . extractChunk $ H.briefDesc p (x *> some (x *> x))+ in r === "X (X X)..."++prop_grouped_many_pairs_argument_ellipsis :: Property+prop_grouped_many_pairs_argument_ellipsis = once $+ let x :: Parser String+ x = strArgument (metavar "X")+ p = prefs (multiSuffix "...")+ r = show . extractChunk $ H.briefDesc p (x *> many (x *> x))+ in r === "X [X X]..."++prop_grouped_some_dual_option_ellipsis :: Property+prop_grouped_some_dual_option_ellipsis = once $+ let x :: Parser String+ x = strOption (short 'a' <> short 'b' <> metavar "X")+ p = prefs (multiSuffix "...")+ r = show . extractChunk $ H.briefDesc p (x *> some x)+ in r === "(-a|-b X) (-a|-b X)..."++prop_grouped_many_dual_option_ellipsis :: Property+prop_grouped_many_dual_option_ellipsis = once $+ let x :: Parser String+ x = strOption (short 'a' <> short 'b' <> metavar "X")+ p = prefs (multiSuffix "...")+ r = show . extractChunk $ H.briefDesc p (x *> many x)+ in r === "(-a|-b X) [-a|-b X]..."++prop_grouped_some_dual_flag_ellipsis :: Property+prop_grouped_some_dual_flag_ellipsis = once $+ let x = flag' () (short 'a' <> short 'b')+ p = prefs (multiSuffix "...")+ r = show . extractChunk $ H.briefDesc p (x *> some x)+ in r === "(-a|-b) (-a|-b)..."++prop_grouped_many_dual_flag_ellipsis :: Property+prop_grouped_many_dual_flag_ellipsis = once $+ let x = flag' () (short 'a' <> short 'b')+ p = prefs (multiSuffix "...")+ r = show . extractChunk $ H.briefDesc p (x *> many x)+ in r === "(-a|-b) [-a|-b]..."++prop_issue_402 :: Property+prop_issue_402 = once $+ let x = some (flag' () (short 'a')) <|> some (flag' () (short 'b' <> internal))+ p = prefs (multiSuffix "...")+ r = show . extractChunk $ H.briefDesc p x+ in r === "(-a)..."++prop_nice_some1 :: Property+prop_nice_some1 = once $+ let x = Options.Applicative.NonEmpty.some1 (flag' () (short 'a'))+ p = prefs (multiSuffix "...")+ r = show . extractChunk $ H.briefDesc p x+ in r === "(-a)..."++prop_some1_works :: Property+prop_some1_works = once $+ let p = Options.Applicative.NonEmpty.some1 (flag' () (short 'a')) i = info p idm- result = run i ["testValue"]- in assertResult result $ \xs -> BS8.pack t === xs+ result = run i ["-a", "-a"]+ in assertResult result $ \xs -> () :| [()] === xs +prop_help_contexts :: Property+prop_help_contexts = once $+ let+ grabHelpMessage (Failure failure) =+ let (msg, ExitSuccess) = renderFailure failure "<text>"+ in msg+ grabHelpMessage _ = error "Parse did not render help text"++ i = Cabal.pinfo+ pre = run i ["install", "--help"]+ post = run i ["--help", "install"]+ in grabHelpMessage pre === grabHelpMessage post++prop_help_unknown_context :: Property+prop_help_unknown_context = once $+ let+ grabHelpMessage (Failure failure) =+ let (msg, ExitSuccess) = renderFailure failure "<text>"+ in msg+ grabHelpMessage _ = error "Parse did not render help text"++ i = Cabal.pinfo+ pre = run i ["--help"]+ post = run i ["--help", "not-a-command"]+ in grabHelpMessage pre === grabHelpMessage post+++prop_long_command_line_flow :: Property+prop_long_command_line_flow = once $+ let p = LongSub.sample <**> helper+ i = info p+ ( progDesc (concat+ [ "This is a very long program description. "+ , "This text should be automatically wrapped "+ , "to fit the size of the terminal" ]) )+ in checkHelpTextWith ExitSuccess (prefs (columns 50)) "formatting-long-subcommand" i ["hello-very-long-sub", "--help"]++prop_parser_group_basic :: Property+prop_parser_group_basic = once $+ checkHelpText "parser_group_basic" ParserGroup.Basic.opts ["--help"]++prop_parser_group_command_groups :: Property+prop_parser_group_command_groups = once $+ checkHelpText "parser_group_command_groups" ParserGroup.CommandGroups.opts ["--help"]++prop_parser_group_duplicate_command_groups :: Property+prop_parser_group_duplicate_command_groups = once $+ checkHelpText "parser_group_duplicate_command_groups" ParserGroup.DuplicateCommandGroups.opts ["--help"]++prop_parser_group_duplicates :: Property+prop_parser_group_duplicates = once $+ checkHelpText "parser_group_duplicates" ParserGroup.Duplicates.opts ["--help"]++prop_parser_group_all_grouped :: Property+prop_parser_group_all_grouped = once $+ checkHelpText "parser_group_all_grouped" ParserGroup.AllGrouped.opts ["--help"]++prop_parser_group_nested :: Property+prop_parser_group_nested = once $+ checkHelpText "parser_group_nested" ParserGroup.Nested.opts ["--help"]+ --- deriving instance Arbitrary a => Arbitrary (Chunk a)-deriving instance Eq SimpleDoc-deriving instance Show SimpleDoc -equalDocs :: Float -> Int -> Doc -> Doc -> Property-equalDocs f w d1 d2 = Doc.renderPretty f w d1- === Doc.renderPretty f w d2 +equalDocs :: Double -> Int -> Doc -> Doc -> Property+equalDocs f w d1 d2 = Doc.prettyString f w d1+ === Doc.prettyString f w d2+ prop_listToChunk_1 :: [String] -> Property prop_listToChunk_1 xs = isEmpty (listToChunk xs) === null xs @@ -794,10 +998,10 @@ prop_extractChunk_2 :: Chunk String -> Property prop_extractChunk_2 x = extractChunk (fmap pure x) === x -prop_stringChunk_1 :: Positive Float -> Positive Int -> String -> Property+prop_stringChunk_1 :: Positive Double -> Positive Int -> String -> Property prop_stringChunk_1 (Positive f) (Positive w) s = equalDocs f w (extractChunk (stringChunk s))- (Doc.string s)+ (Doc.pretty s) prop_stringChunk_2 :: String -> Property prop_stringChunk_2 s = isEmpty (stringChunk s) === null s