diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,14 @@ +## 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. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -43,6 +43,7 @@ - [Applicative Do](#applicative-do) - [FAQ](#faq) - [How it works](#how-it-works) +- [Tutorials](#tutorials) ## Introduction @@ -509,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 @@ -554,7 +555,7 @@ modifier. For example, ```haskell -subparser +hsubparser ( command "add" (info addCommand ( progDesc "Add a file to the repository" )) <> command "commit" (info commitCommand ( progDesc "Record changes to the repository" )) ) @@ -572,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) ) @@ -721,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` @@ -748,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: +
+ + +Group A + + +Group B + +``` + +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 @@ -763,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:" @@ -1015,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 @@ -1030,4 +1085,4 @@ [parsec]: http://hackage.haskell.org/package/parsec [status]: https://github.com/pcapriotti/optparse-applicative/actions/workflows/haskell-ci.yml [status-png]: https://github.com/pcapriotti/optparse-applicative/workflows/Haskell-CI/badge.svg - [ansi-wl-pprint]: http://hackage.haskell.org/package/ansi-wl-pprint + [prettyprinter]: http://hackage.haskell.org/package/prettyprinter diff --git a/optparse-applicative.cabal b/optparse-applicative.cabal --- a/optparse-applicative.cabal +++ b/optparse-applicative.cabal @@ -1,5 +1,5 @@ name: optparse-applicative -version: 0.18.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 @@ -39,12 +39,21 @@ tests/formatting-long-subcommand.err.txt tests/nested.err.txt tests/optional.err.txt + tests/parser_group_all_grouped.err.txt + tests/parser_group_basic.err.txt + tests/parser_group_command_groups.err.txt + tests/parser_group_duplicate_command_groups.err.txt + tests/parser_group_duplicates.err.txt + tests/parser_group_nested.err.txt tests/nested_optional.err.txt tests/subparsers.err.txt homepage: https://github.com/pcapriotti/optparse-applicative bug-reports: https://github.com/pcapriotti/optparse-applicative/issues tested-with: + GHC==9.12.1 + GHC==9.10.1 + GHC==9.8.4 GHC==9.6.1 GHC==9.4.4 GHC==9.2.7 @@ -100,18 +109,17 @@ , Options.Applicative.Types , Options.Applicative.Internal - build-depends: base >= 4.5 && < 5 + build-depends: base >= 4.5 && < 5 , text >= 1.2 - , transformers >= 0.2 && < 0.7 - , transformers-compat >= 0.3 && < 0.8 - , prettyprinter >= 1.7 && < 1.8 - , prettyprinter-ansi-terminal >= 1.1 && < 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 + build-depends: process >= 1.0 && < 1.7 if !impl(ghc >= 8) - build-depends: semigroups >= 0.10 && < 0.21 + build-depends: semigroups >= 0.10 && < 0.21 , fail == 4.9.* test-suite tests @@ -131,10 +139,16 @@ , Examples.Formatting , Examples.Hello , Examples.LongSub + , Examples.ParserGroup.AllGrouped + , Examples.ParserGroup.Basic + , Examples.ParserGroup.CommandGroups + , Examples.ParserGroup.DuplicateCommandGroups + , Examples.ParserGroup.Duplicates + , Examples.ParserGroup.Nested build-depends: base , optparse-applicative - , QuickCheck >= 2.8 && < 2.15 + , QuickCheck >= 2.8 && < 2.16 if !impl(ghc >= 8) build-depends: semigroups diff --git a/src/Options/Applicative.hs b/src/Options/Applicative.hs --- a/src/Options/Applicative.hs +++ b/src/Options/Applicative.hs @@ -7,7 +7,7 @@ -- See 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'. @@ -81,7 +81,7 @@ -- | '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, @@ -105,6 +105,7 @@ completer, idm, mappend, + parserOptionGroup, OptionFields, FlagFields, @@ -115,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, @@ -199,6 +202,7 @@ helpLongEquals, helpShowGlobals, helpIndent, + briefHangPoint, defaultPrefs, -- * Completions diff --git a/src/Options/Applicative/Builder.hs b/src/Options/Applicative/Builder.hs --- a/src/Options/Applicative/Builder.hs +++ b/src/Options/Applicative/Builder.hs @@ -49,6 +49,7 @@ completer, idm, mappend, + parserOptionGroup, -- * Readers -- @@ -89,6 +90,7 @@ helpLongEquals, helpShowGlobals, helpIndent, + briefHangPoint, prefs, defaultPrefs, @@ -107,8 +109,8 @@ ) where import Control.Applicative -#if __GLASGOW_HASKELL__ <= 802 -import Data.Semigroup hiding (option) +#if __GLASGOW_HASKELL__ < 804 +import Data.Semigroup hiding (Option, option) #endif import Data.String (fromString, IsString) @@ -118,6 +120,7 @@ import Options.Applicative.Types import Options.Applicative.Help.Pretty import Options.Applicative.Help.Chunk +import Options.Applicative.Internal (mapParserOptions) -- Readers -- @@ -379,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: +-- >
+-- > +-- > +-- > Group A +-- > +-- > +-- > Group B +-- > +-- +-- @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 } @@ -530,6 +583,9 @@ 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 @@ -545,7 +601,8 @@ , prefColumns = 80 , prefHelpLongEquals = False , prefHelpShowGlobal = False - , prefTabulateFill = 24 } + , prefTabulateFill = 24 + , prefBriefHangPoint = 35 } -- Convenience shortcuts diff --git a/src/Options/Applicative/Builder/Internal.hs b/src/Options/Applicative/Builder/Internal.hs --- a/src/Options/Applicative/Builder/Internal.hs +++ b/src/Options/Applicative/Builder/Internal.hs @@ -120,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) @@ -150,6 +151,7 @@ , propShowDefault = Nothing , propDescMod = Nothing , propShowGlobal = True + , propGroup = OptGroup [] } mkCommand :: Mod CommandFields a -> (Maybe String, [(String, ParserInfo a)]) @@ -184,7 +186,8 @@ -- | Hide this option completely from the help text -- --- Use 'hidden' if the option should remain visible in the full description. +-- Use 'Options.Applicative.hidden' if the option should remain visible in the +-- full description. internal :: Mod f a internal = optionMod $ \p -> p { propVisibility = Internal } diff --git a/src/Options/Applicative/Common.hs b/src/Options/Applicative/Common.hs --- a/src/Options/Applicative/Common.hs +++ b/src/Options/Applicative/Common.hs @@ -182,8 +182,10 @@ ArgReader rdr -> fmap pure . lift . lift $ runReadM (crReader rdr) arg - _ -> mzero + _ -> + mzero + where cmdMatches cs | prefDisambiguate prefs = snd <$> filter (isPrefixOf arg . fst) cs @@ -266,8 +268,8 @@ -- | Like 'mapParser', but collect the results in a tree structure. treeMapParser :: (forall x. ArgumentReachability -> Option x -> b) - -> Parser a - -> OptTree b + -> Parser a + -> OptTree b treeMapParser g = simplify . go False g where has_default :: Parser a -> Bool diff --git a/src/Options/Applicative/Help/Chunk.hs b/src/Options/Applicative/Help/Chunk.hs --- a/src/Options/Applicative/Help/Chunk.hs +++ b/src/Options/Applicative/Help/Chunk.hs @@ -22,7 +22,7 @@ import Options.Applicative.Help.Pretty --- | The free monoid on a semigroup 'a'. +-- | The free monoid on a semigroup @a@. newtype Chunk a = Chunk { unChunk :: Maybe a } deriving (Eq, Show) @@ -53,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) diff --git a/src/Options/Applicative/Help/Core.hs b/src/Options/Applicative/Help/Core.hs --- a/src/Options/Applicative/Help/Core.hs +++ b/src/Options/Applicative/Help/Core.hs @@ -19,20 +19,18 @@ parserGlobals ) where -import Control.Applicative -import Control.Monad (guard) -import Data.Function (on) -import Data.List (sort, intersperse, groupBy) -import Data.Foldable (any, foldl') -import Data.Maybe (catMaybes, fromMaybe) -#if !MIN_VERSION_base(4,8,0) -import Data.Monoid (mempty) -#endif -#if !MIN_VERSION_base(4,11,0) -import Data.Semigroup (Semigroup (..)) -#endif -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 @@ -50,16 +48,17 @@ safelast = foldl' (const Just) Nothing -- | Generate description for a single option. -optDesc :: ParserPrefs -> OptDescStyle -> ArgumentReachability -> Option a -> (Chunk Doc, Parenthetic) +optDesc :: ParserPrefs -> OptDescStyle -> ArgumentReachability -> Option a -> (OptGroup, Chunk Doc, Parenthetic) optDesc pprefs style _reachability opt = let names = - sort . optionNames . optMain $ opt + List.sort . optionNames . optMain $ opt meta = stringChunk $ optMetaVar opt + grp = propGroup $ optProps opt descs = map (pretty . showOption) names descriptions = - listToChunk (intersperse (descSep style) descs) + listToChunk (List.intersperse (descSep style) descs) desc | prefHelpLongEquals pprefs && not (isEmpty meta) && any isLongName (safelast names) = descriptions <> stringChunk "=" <> meta @@ -86,7 +85,7 @@ desc modified = maybe id fmap (optDescMod opt) rendered - in (modified, wrapping) + in (grp, modified, wrapping) -- | Generate descriptions for commands. cmdDesc :: ParserPrefs -> Parser a -> [(Maybe String, Chunk Doc)] @@ -117,10 +116,10 @@ briefDesc' showOptional pprefs = wrapOver NoDefault MaybeRequired . foldTree pprefs style - . mfilterOptional - . treeMapParser (optDesc pprefs style) + . mFilterOptional + . treeMapParser optDesc' where - mfilterOptional + mFilterOptional | showOptional = id | otherwise = @@ -130,6 +129,12 @@ descHidden = False, descGlobal = False } + optDesc' reach opt = + let + (_, a, b) = + optDesc pprefs style reach opt + in + (a, b) -- | Wrap a doc in parentheses or brackets if required. wrapOver :: AltNodeType -> Parenthetic -> (Chunk Doc, Parenthetic) -> Chunk Doc @@ -152,11 +157,11 @@ x = foldr go mempty xs wrapLevel = - mult_wrap xs + multi_wrap xs in (x, wrapLevel) where - mult_wrap [_] = NeverRequired - mult_wrap _ = MaybeRequired + multi_wrap [_] = NeverRequired + multi_wrap _ = MaybeRequired foldTree prefs s (AltNode b xs) = (\x -> (x, NeverRequired)) . fmap groupOrNestLine @@ -193,14 +198,136 @@ -- | Common generator for full descriptions and globals optionsDesc :: Bool -> ParserPrefs -> Parser a -> Chunk Doc -optionsDesc global pprefs = tabulate (prefTabulateFill pprefs) . catMaybes . mapParser 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 (pretty "default:" <+> pretty s) @@ -210,6 +337,27 @@ 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 } @@ -238,11 +386,11 @@ parserHelp :: ParserPrefs -> Parser a -> ParserHelp parserHelp pprefs p = bodyHelp . vsepChunks $ - with_title "Available options:" (fullDesc pprefs p) + fullDesc pprefs p : (group_title <$> cs) where def = "Available commands:" - cs = groupBy ((==) `on` fst) $ cmdDesc pprefs p + cs = groupFstAll $ cmdDesc pprefs p group_title a@((n, _) : _) = with_title (fromMaybe def n) $ @@ -255,9 +403,7 @@ parserGlobals :: ParserPrefs -> Parser a -> ParserHelp parserGlobals pprefs p = - globalsHelp $ - (.$.) <$> stringChunk "Global options:" - <*> globalDesc pprefs p + globalsHelp $ globalDesc pprefs p @@ -268,7 +414,7 @@ hsep [ pretty "Usage:", pretty progn, - hangAtIfOver 9 35 (extractChunk (briefDesc pprefs p)) + hangAtIfOver 9 (prefBriefHangPoint pprefs) (extractChunk (briefDesc pprefs p)) ] -- | Peek at the structure of the rendered tree within. @@ -286,3 +432,55 @@ | AlwaysRequired -- ^ Parenthesis should always be used. deriving (Eq, Ord, Show) + +-- | Groups on the first element of the tuple. This differs from the simple +-- @groupBy ((==) `on` fst)@ in that non-adjacent groups are __also__ grouped +-- together. For example: +-- +-- @ +-- groupFst = groupBy ((==) `on` fst) +-- +-- let xs = [(1, "a"), (1, "b"), (3, "c"), (2, "d"), (3, "e"), (2, "f")] +-- +-- groupFst xs === [[(1,"a"),(1,"b")],[(3,"c")],[(2,"d")],[(3,"e")],[(2,"f")]] +-- groupFstAll xs === [[(1,"a"),(1,"b")],[(3,"c"),(3,"e")],[(2,"d"),(2,"f")]] +-- @ +-- +-- Notice that the original order is preserved i.e. we do not first sort on +-- the first element. +-- +-- @since 0.19.0.0 +groupFstAll :: Ord a => [(a, b)] -> [[(a, b)]] +groupFstAll = + -- In order to group all (adjacent + non-adjacent) Eq elements together, we + -- sort the list so that the Eq elements are in fact adjacent, _then_ group. + -- We don't want to destroy the original order, however, so we add a + -- temporary index that maintains this original order. The full logic is: + -- + -- 1. Add index i that preserves original order. + -- 2. Sort on tuple's fst. + -- 3. Group by fst. + -- 4. Sort by i, restoring original order. + -- 5. Drop index i. + fmap (NE.toList . dropIdx) + . List.sortOn toIdx + . NE.groupBy ((==) `on` fst') + . List.sortOn fst' + . zipWithIndex + where + dropIdx :: NonEmpty (Int, (a, b)) -> NonEmpty (a, b) + dropIdx = fmap snd + + toIdx :: NonEmpty (Int, (a, b)) -> Int + toIdx ((x, _) :| _) = x + + -- Like fst, ignores our added index + fst' :: (Int, (a, b)) -> a + fst' (_, (x, _)) = x + + zipWithIndex :: [(a, b)] -> [(Int, (a, b))] + zipWithIndex = zip [1 ..] + +-- | From base-4.19.0.0. +unsnoc :: [a] -> Maybe ([a], a) +unsnoc = foldr (\x -> Just . maybe ([], x) (\(~(a, b)) -> (x : a, b))) Nothing diff --git a/src/Options/Applicative/Internal.hs b/src/Options/Applicative/Internal.hs --- a/src/Options/Applicative/Internal.hs +++ b/src/Options/Applicative/Internal.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE RankNTypes #-} + module Options.Applicative.Internal ( P , MonadP(..) @@ -24,6 +26,8 @@ , cut , () , disamb + + , mapParserOptions ) where import Control.Applicative @@ -36,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 @@ -266,3 +271,16 @@ 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)) diff --git a/src/Options/Applicative/Types.hs b/src/Options/Applicative/Types.hs --- a/src/Options/Applicative/Types.hs +++ b/src/Options/Applicative/Types.hs @@ -11,6 +11,7 @@ OptReader(..), OptProperties(..), + OptGroup(..), OptVisibility(..), Backtracking(..), ReadM(..), @@ -126,7 +127,8 @@ , prefHelpShowGlobal :: Bool -- ^ when displaying subparsers' usage help, -- show parent options under a "global options" -- section (default: False) - , prefTabulateFill ::Int -- ^ Indentation width for tables + , prefTabulateFill ::Int -- ^ Indentation width for tables + , prefBriefHangPoint :: Int -- ^ Width at which to hang the brief description } deriving (Eq, Show) data OptName = OptShort !Char @@ -147,6 +149,12 @@ | 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 @@ -155,17 +163,23 @@ , propShowDefault :: Maybe String -- ^ what to show in the help text as the default , propShowGlobal :: Bool -- ^ whether the option is presented in global options text , propDescMod :: Maybe ( Doc -> Doc ) -- ^ a function to run over the brief description + , propGroup :: OptGroup + -- ^ optional group(s) + -- + -- @since 0.19.0.0 } instance Show OptProperties where - showsPrec p (OptProperties pV pH pMV pSD pSG _) + showsPrec p (OptProperties pV pH pMV pSD pSG _ pGrp) = showParen (p >= 11) $ showString "OptProperties { propVisibility = " . shows pV . showString ", propHelp = " . shows pH . showString ", propMetaVar = " . shows pMV . showString ", propShowDefault = " . shows pSD . showString ", propShowGlobal = " . shows pSG - . showString ", propDescMod = _ }" + . showString ", propDescMod = _" + . showString ", propGroup = " . shows pGrp + . showString "}" -- | A single option of a parser. data Option a = Option @@ -175,8 +189,9 @@ 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. +-- | 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 @@ -251,7 +266,7 @@ fmap f (ArgReader cr) = ArgReader (fmap f cr) fmap f (CmdReader n cs) = CmdReader n ((fmap . fmap . fmap) f cs) --- | A @Parser a@ is an option parser returning a value of type 'a'. +-- | A @Parser a@ is an option parser returning a value of type @a@. data Parser a = NilP (Maybe a) | OptP (Option a) @@ -342,7 +357,7 @@ 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) diff --git a/tests/Examples/ParserGroup/AllGrouped.hs b/tests/Examples/ParserGroup/AllGrouped.hs new file mode 100644 --- /dev/null +++ b/tests/Examples/ParserGroup/AllGrouped.hs @@ -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 diff --git a/tests/Examples/ParserGroup/Basic.hs b/tests/Examples/ParserGroup/Basic.hs new file mode 100644 --- /dev/null +++ b/tests/Examples/ParserGroup/Basic.hs @@ -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 diff --git a/tests/Examples/ParserGroup/CommandGroups.hs b/tests/Examples/ParserGroup/CommandGroups.hs new file mode 100644 --- /dev/null +++ b/tests/Examples/ParserGroup/CommandGroups.hs @@ -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 diff --git a/tests/Examples/ParserGroup/DuplicateCommandGroups.hs b/tests/Examples/ParserGroup/DuplicateCommandGroups.hs new file mode 100644 --- /dev/null +++ b/tests/Examples/ParserGroup/DuplicateCommandGroups.hs @@ -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 diff --git a/tests/Examples/ParserGroup/Duplicates.hs b/tests/Examples/ParserGroup/Duplicates.hs new file mode 100644 --- /dev/null +++ b/tests/Examples/ParserGroup/Duplicates.hs @@ -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 + diff --git a/tests/Examples/ParserGroup/Nested.hs b/tests/Examples/ParserGroup/Nested.hs new file mode 100644 --- /dev/null +++ b/tests/Examples/ParserGroup/Nested.hs @@ -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 diff --git a/tests/parser_group_all_grouped.err.txt b/tests/parser_group_all_grouped.err.txt new file mode 100644 --- /dev/null +++ b/tests/parser_group_all_grouped.err.txt @@ -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 diff --git a/tests/parser_group_basic.err.txt b/tests/parser_group_basic.err.txt new file mode 100644 --- /dev/null +++ b/tests/parser_group_basic.err.txt @@ -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 diff --git a/tests/parser_group_command_groups.err.txt b/tests/parser_group_command_groups.err.txt new file mode 100644 --- /dev/null +++ b/tests/parser_group_command_groups.err.txt @@ -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 diff --git a/tests/parser_group_duplicate_command_groups.err.txt b/tests/parser_group_duplicate_command_groups.err.txt new file mode 100644 --- /dev/null +++ b/tests/parser_group_duplicate_command_groups.err.txt @@ -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 diff --git a/tests/parser_group_duplicates.err.txt b/tests/parser_group_duplicates.err.txt new file mode 100644 --- /dev/null +++ b/tests/parser_group_duplicates.err.txt @@ -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 diff --git a/tests/parser_group_nested.err.txt b/tests/parser_group_nested.err.txt new file mode 100644 --- /dev/null +++ b/tests/parser_group_nested.err.txt @@ -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 diff --git a/tests/test.hs b/tests/test.hs --- a/tests/test.hs +++ b/tests/test.hs @@ -10,9 +10,16 @@ import qualified Examples.Alternatives as Alternatives import qualified Examples.Formatting as Formatting import qualified Examples.LongSub as LongSub +import qualified Examples.ParserGroup.AllGrouped as ParserGroup.AllGrouped +import qualified Examples.ParserGroup.Basic as ParserGroup.Basic +import qualified Examples.ParserGroup.CommandGroups as ParserGroup.CommandGroups +import qualified Examples.ParserGroup.DuplicateCommandGroups as ParserGroup.DuplicateCommandGroups +import qualified Examples.ParserGroup.Duplicates as ParserGroup.Duplicates +import qualified Examples.ParserGroup.Nested as ParserGroup.Nested import Control.Applicative import Control.Monad +import Data.Function (on) import Data.List hiding (group) import Data.List.NonEmpty (NonEmpty ((:|))) import Data.Semigroup hiding (option) @@ -945,6 +952,30 @@ , "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"] ---