diff --git a/CHANGELOG.md b/CHANGELOG.md index d397e8c2..87d71419 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,9 @@ +## Version 0.19.0.0 + +- 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 index 8c61e555..8658739a 100644 --- a/README.md +++ b/README.md @@ -748,6 +748,48 @@ main = customExecParser p opts 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: + + +Available options: + +``` + +Caveats: + +- Parser groups are like command groups in that groups are listed in creation + order, and (non-consecutive) duplicate groups are allowed. + +- Nested groups are concatenated: + + ```haskell + parserOptionGroup "Group A" (parserOptionGroup "Group Z" parseA) + ``` + + Will group `parseA` under `GroupA.Group Z`. + ### Command groups One experimental feature which may be useful for programs with many diff --git a/optparse-applicative.cabal b/optparse-applicative.cabal index 7da4eda5..761b1621 100644 --- a/optparse-applicative.cabal +++ b/optparse-applicative.cabal @@ -39,6 +39,11 @@ extra-source-files: CHANGELOG.md 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_duplicates.err.txt + tests/parser_group_nested.err.txt tests/nested_optional.err.txt tests/subparsers.err.txt @@ -131,6 +136,12 @@ test-suite tests , 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 diff --git a/src/Options/Applicative.hs b/src/Options/Applicative.hs index d428badf..a76de748 100644 --- a/src/Options/Applicative.hs +++ b/src/Options/Applicative.hs @@ -105,6 +105,7 @@ module Options.Applicative ( completer, idm, mappend, + parserOptionGroup, OptionFields, FlagFields, diff --git a/src/Options/Applicative/Builder.hs b/src/Options/Applicative/Builder.hs index bc12b5f2..e2999487 100644 --- a/src/Options/Applicative/Builder.hs +++ b/src/Options/Applicative/Builder.hs @@ -49,6 +49,7 @@ module Options.Applicative.Builder ( completer, idm, mappend, + parserOptionGroup, -- * Readers -- @@ -118,6 +119,7 @@ import Options.Applicative.Common import Options.Applicative.Types import Options.Applicative.Help.Pretty import Options.Applicative.Help.Chunk +import Options.Applicative.Internal (mapParserOptions) -- Readers -- @@ -379,6 +381,65 @@ option r m = mkParser d g rdr crdr = CReader (optCompleter fields) r rdr = OptReader (optNames fields) crdr (optNoArgError fields) +-- | Prepends a group to 'OptProperties'. Nested groups are concatenated +-- together 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 : gs) } + where + OptGroup gs = 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) + +-- | This function can be used to group options together under a common +-- heading. 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: +-- > +-- > +-- > Available options: +-- > +-- +-- Caveats: +-- +-- - Parser groups are like command groups in that groups are listed in +-- creation order, and (non-consecutive) duplicate groups are allowed. +-- +-- - Nested groups are concatenated: +-- +-- @ +-- parserOptionGroup "Group A" (parserOptionGroup "Group Z" parseA) +-- @ +-- +-- Will group @parseA@ under @"GroupA.Group Z"@. +-- +-- @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 } diff --git a/src/Options/Applicative/Builder/Internal.hs b/src/Options/Applicative/Builder/Internal.hs index 82d06780..2110067b 100644 --- a/src/Options/Applicative/Builder/Internal.hs +++ b/src/Options/Applicative/Builder/Internal.hs @@ -151,6 +151,7 @@ baseProps = OptProperties , propShowDefault = Nothing , propDescMod = Nothing , propShowGlobal = True + , propGroup = OptGroup [] } mkCommand :: Mod CommandFields a -> (Maybe String, [(String, ParserInfo a)]) diff --git a/src/Options/Applicative/Help/Core.hs b/src/Options/Applicative/Help/Core.hs index ce89070f..03e87730 100644 --- a/src/Options/Applicative/Help/Core.hs +++ b/src/Options/Applicative/Help/Core.hs @@ -22,9 +22,9 @@ module Options.Applicative.Help.Core ( import Control.Applicative import Control.Monad (guard) import Data.Function (on) -import Data.List (sort, intersperse, groupBy) +import Data.List (sort, intercalate, intersperse, groupBy) import Data.Foldable (any, foldl') -import Data.Maybe (catMaybes, fromMaybe) +import Data.Maybe (fromMaybe) #if !MIN_VERSION_base(4,8,0) import Data.Monoid (mempty) #endif @@ -34,6 +34,7 @@ import Data.Semigroup (Semigroup (..)) import Prelude hiding (any) import Options.Applicative.Common +import Options.Applicative.Internal (groupFst) import Options.Applicative.Types import Options.Applicative.Help.Pretty import Options.Applicative.Help.Chunk @@ -50,12 +51,13 @@ safelast :: [a] -> Maybe a 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 meta = stringChunk $ optMetaVar opt + grp = propGroup $ optProps opt descs = map (pretty . showOption) names descriptions = @@ -86,7 +88,7 @@ optDesc pprefs style _reachability opt = 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)] @@ -118,7 +120,7 @@ briefDesc' showOptional pprefs = wrapOver NoDefault MaybeRequired . foldTree pprefs style . mfilterOptional - . treeMapParser (optDesc pprefs style) + . treeMapParser (\a -> (\(_, x, y) -> (x, y)) . optDesc pprefs style a) where mfilterOptional | showOptional = @@ -193,14 +195,41 @@ globalDesc = optionsDesc True -- | 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 + . fmap formatTitle + . fmap tabulateGroup + . groupByTitle + $ mapParser doc p where + groupByTitle :: [Maybe (OptGroup, (Doc, Doc))] -> [[(OptGroup, (Doc, Doc))]] + groupByTitle = groupFst + + tabulateGroup :: [(OptGroup, (Doc, Doc))] -> (OptGroup, Chunk Doc) + tabulateGroup l@((title,_):_) = (title, tabulate (prefTabulateFill pprefs) (snd <$> l)) + tabulateGroup [] = mempty + + -- Note that we treat Global/Available options identically, when it comes + -- to titles. + formatTitle :: (OptGroup, Chunk Doc) -> Chunk Doc + formatTitle (OptGroup groups, opts) = + case groups of + [] -> (pretty defTitle .$.) <$> opts + gs@(_:_) -> (renderGroupStr gs .$.) <$> opts + where + defTitle = + if global + then "Global options:" + else "Available options:" + + renderGroupStr = (<> pretty ":") . pretty . intercalate "." + + 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) @@ -238,7 +267,7 @@ footerHelp chunk = mempty { helpFooter = chunk } 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:" @@ -255,9 +284,7 @@ parserHelp pprefs p = parserGlobals :: ParserPrefs -> Parser a -> ParserHelp parserGlobals pprefs p = - globalsHelp $ - (.$.) <$> stringChunk "Global options:" - <*> globalDesc pprefs p + globalsHelp $ globalDesc pprefs p diff --git a/src/Options/Applicative/Internal.hs b/src/Options/Applicative/Internal.hs index b4831447..34d61b5c 100644 --- 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,9 @@ module Options.Applicative.Internal , cut , () , disamb + + , mapParserOptions + , groupFst ) where import Control.Applicative @@ -35,6 +40,9 @@ import Control.Monad.Trans.Except import Control.Monad.Trans.Reader (mapReaderT, runReader, runReaderT, Reader, ReaderT, ask) import Control.Monad.Trans.State (StateT, get, put, modify, evalStateT, runStateT) +import Data.Function (on) +import Data.List (groupBy) +import Data.Maybe (catMaybes) import Options.Applicative.Types @@ -266,3 +274,22 @@ hoistList :: Alternative m => [a] -> m a hoistList = foldr cons empty where cons x xs = pure x <|> xs + +-- | Strips 'Nothing', then groups on the first element of the tuple. +-- +-- @since 0.19.0.0 +groupFst :: (Eq a) => [Maybe (a, b)] -> [[(a, b)]] +groupFst = groupBy ((==) `on` fst) . catMaybes + +-- | 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 index 7e11ead4..695b485b 100644 --- a/src/Options/Applicative/Types.hs +++ b/src/Options/Applicative/Types.hs @@ -11,6 +11,7 @@ module Options.Applicative.Types ( OptReader(..), OptProperties(..), + OptGroup(..), OptVisibility(..), Backtracking(..), ReadM(..), @@ -147,6 +148,18 @@ data OptVisibility | 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, Show) + +instance Semigroup OptGroup where + OptGroup xs <> OptGroup ys = OptGroup (xs ++ ys) + +instance Monoid OptGroup where + mempty = OptGroup [] + -- | Specification for an individual parser option. data OptProperties = OptProperties { propVisibility :: OptVisibility -- ^ whether this flag is shown in the brief description @@ -155,17 +168,23 @@ data OptProperties = OptProperties , 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 (nested) group + -- + -- @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 diff --git a/tests/Examples/ParserGroup/AllGrouped.hs b/tests/Examples/ParserGroup/AllGrouped.hs new file mode 100644 index 00000000..ca2bf0be --- /dev/null +++ b/tests/Examples/ParserGroup/AllGrouped.hs @@ -0,0 +1,92 @@ +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE NamedFieldPuns #-} + +module Examples.ParserGroup.AllGrouped (opts) where + +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 = do + logGroup <- parseLogGroup + systemGroup <- parseSystemGroup + cmd <- parseCmd + + pure $ + Sample + { logGroup, + systemGroup, + cmd + } + 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" + ) diff --git a/tests/Examples/ParserGroup/Basic.hs b/tests/Examples/ParserGroup/Basic.hs new file mode 100644 index 00000000..cd710f5d --- /dev/null +++ b/tests/Examples/ParserGroup/Basic.hs @@ -0,0 +1,114 @@ +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE NamedFieldPuns #-} + +module Examples.ParserGroup.Basic (opts) where + +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 = do + hello <- parseHello + logGroup <- parseLogGroup + quiet <- parseQuiet + systemGroup <- parseSystemGroup + verbosity <- parseVerbosity + cmd <- parseCmd + + pure $ + Sample + { hello, + logGroup, + quiet, + systemGroup, + verbosity, + cmd + } + 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" + ) diff --git a/tests/Examples/ParserGroup/CommandGroups.hs b/tests/Examples/ParserGroup/CommandGroups.hs new file mode 100644 index 00000000..eb2ca153 --- /dev/null +++ b/tests/Examples/ParserGroup/CommandGroups.hs @@ -0,0 +1,137 @@ +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} + +module Examples.ParserGroup.CommandGroups (opts) where + +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 = do + hello <- parseHello + logGroup <- parseLogGroup + quiet <- parseQuiet + systemGroup <- parseSystemGroup + verbosity <- parseVerbosity + cmd <- parseCommand + + pure $ + Sample + { hello, + logGroup, + quiet, + systemGroup, + verbosity, + cmd + } + 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" + ) diff --git a/tests/Examples/ParserGroup/DuplicateCommandGroups.hs b/tests/Examples/ParserGroup/DuplicateCommandGroups.hs new file mode 100644 index 00000000..b727ec7a --- /dev/null +++ b/tests/Examples/ParserGroup/DuplicateCommandGroups.hs @@ -0,0 +1,93 @@ +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} + +module Examples.ParserGroup.DuplicateCommandGroups (opts) where + +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 = do + hello <- parseHello + quiet <- parseQuiet + verbosity <- parseVerbosity + cmd <- parseCommand + + pure $ + Sample + { hello, + quiet, + verbosity, + cmd + } + 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" + ) diff --git a/tests/Examples/ParserGroup/Duplicates.hs b/tests/Examples/ParserGroup/Duplicates.hs new file mode 100644 index 00000000..929b9515 --- /dev/null +++ b/tests/Examples/ParserGroup/Duplicates.hs @@ -0,0 +1,159 @@ +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE NamedFieldPuns #-} + +module Examples.ParserGroup.Duplicates (opts) where + +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 = do + hello <- parseHello + logGroup1 <- parseLogGroup1 + quiet <- parseQuiet + systemGroup1 <- parseSystemGroup1 + systemGroup2 <- parseSystemGroup2 + logGroup2 <- parseLogGroup2 + verbosity <- parseVerbosity + cmd <- parseCmd + + pure $ + Sample + { hello, + logGroup1, + quiet, + systemGroup1, + systemGroup2, + logGroup2, + verbosity, + cmd + } + 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" + ) diff --git a/tests/Examples/ParserGroup/Nested.hs b/tests/Examples/ParserGroup/Nested.hs new file mode 100644 index 00000000..05baab80 --- /dev/null +++ b/tests/Examples/ParserGroup/Nested.hs @@ -0,0 +1,124 @@ +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE NamedFieldPuns #-} + +module Examples.ParserGroup.Nested (opts) where + +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, + timeout :: Int + } + deriving (Show) + +data Sample = Sample + { hello :: String, + logGroup :: LogGroup, + quiet :: Bool, + verbosity :: Int, + cmd :: String + } + deriving (Show) + +sample :: Parser Sample +sample = do + hello <- parseHello + logGroup <- parseLogGroup + quiet <- parseQuiet + verbosity <- parseVerbosity + cmd <- parseCmd + + pure $ + Sample + { hello, + logGroup, + quiet, + verbosity, + cmd + } + where + parseHello = + strOption + ( long "hello" + <> metavar "TARGET" + <> help "Target for the greeting" + ) + + parseLogGroup = parserOptionGroup "Logging" $ do + logPath <- parseLogPath + systemGroup <- parseSystemGroup + logVerbosity <- parseLogVerbosity + pure $ + LogGroup + { logPath, + systemGroup, + logVerbosity + } + 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" + ) + <*> ( 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 "Nested parser groups" + <> header "parser_group.nested - a test for optparse-applicative" + ) diff --git a/tests/parser_group_all_grouped.err.txt b/tests/parser_group_all_grouped.err.txt new file mode 100644 index 00000000..148bec24 --- /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 index 00000000..4a2b6c10 --- /dev/null +++ b/tests/parser_group_basic.err.txt @@ -0,0 +1,25 @@ +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 + +Logging: + --file-log-path PATH Log file path + --file-log-verbosity INT File log verbosity + +Available options: + -q,--quiet Whether to be quiet + +System Options: + --poll Whether to poll + --timeout INT Whether to time out + +Available options: + -v,--verbosity ARG Console verbosity + -h,--help Show this help text diff --git a/tests/parser_group_command_groups.err.txt b/tests/parser_group_command_groups.err.txt new file mode 100644 index 00000000..524ef657 --- /dev/null +++ b/tests/parser_group_command_groups.err.txt @@ -0,0 +1,39 @@ +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 + +Logging: + --file-log-path PATH Log file path + --file-log-verbosity INT File log verbosity + +Available options: + -q,--quiet Whether to be quiet + +System Options: + --poll Whether to poll + --timeout INT Whether to time out + +Available options: + -v,--verbosity ARG Console verbosity + -h,--help Show this help text + +Available commands: + list 2 Lists elements + +Info commands + list Lists elements + print Prints table + +Available commands: + delete Deletes elements + +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 index 00000000..d18a60f2 --- /dev/null +++ b/tests/parser_group_duplicate_command_groups.err.txt @@ -0,0 +1,26 @@ +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 + +Info commands + list Lists elements + +Update commands + delete Deletes elements + insert Inserts elements + +Available commands: + query Runs a query + +Info commands + print Prints table diff --git a/tests/parser_group_duplicates.err.txt b/tests/parser_group_duplicates.err.txt new file mode 100644 index 00000000..0b4dc7f9 --- /dev/null +++ b/tests/parser_group_duplicates.err.txt @@ -0,0 +1,30 @@ +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 + +Logging: + --file-log-path PATH Log file path + --file-log-verbosity INT File log verbosity + +Available options: + -q,--quiet Whether to be quiet + +System: + --poll Whether to poll + --timeout INT Whether to time out + --sysFlag Some flag + +Logging: + --log-namespace STR Log namespace + +Available options: + -v,--verbosity ARG Console verbosity + -h,--help Show this help text diff --git a/tests/parser_group_nested.err.txt b/tests/parser_group_nested.err.txt new file mode 100644 index 00000000..8905f8e6 --- /dev/null +++ b/tests/parser_group_nested.err.txt @@ -0,0 +1,25 @@ +parser_group.nested - a test for optparse-applicative + +Usage: parser_group_nested --hello TARGET [--file-log-path PATH] [--poll] + --timeout INT [--file-log-verbosity INT] [-q|--quiet] + (-v|--verbosity ARG) Command + + Nested parser groups + +Available options: + --hello TARGET Target for the greeting + +Logging: + --file-log-path PATH Log file path + +Logging.System Options: + --poll Whether to poll + --timeout INT Whether to time out + +Logging: + --file-log-verbosity INT File log verbosity + +Available options: + -q,--quiet Whether to be quiet + -v,--verbosity ARG Console verbosity + -h,--help Show this help text diff --git a/tests/test.hs b/tests/test.hs index 4c888dca..dfedc1c7 100644 --- a/tests/test.hs +++ b/tests/test.hs @@ -10,13 +10,21 @@ import qualified Examples.Cabal as Cabal import qualified Examples.Alternatives as Alternatives import qualified Examples.Formatting as Formatting import qualified Examples.LongSub as LongSub +import qualified Examples.ParserGroup.AllGrouped as ParserGroup.AllGrouped +import qualified Examples.ParserGroup.Basic as ParserGroup.Basic +import qualified Examples.ParserGroup.CommandGroups as ParserGroup.CommandGroups +import qualified Examples.ParserGroup.DuplicateCommandGroups as ParserGroup.DuplicateCommandGroups +import qualified Examples.ParserGroup.Duplicates as ParserGroup.Duplicates +import qualified Examples.ParserGroup.Nested as ParserGroup.Nested import Control.Applicative import Control.Monad +import Data.Function (on) import Data.List hiding (group) import Data.List.NonEmpty (NonEmpty ((:|))) import Data.Semigroup hiding (option) import Data.String +import GHC.Stack.Types (HasCallStack) import System.Exit import Test.QuickCheck hiding (Success, Failure) @@ -32,6 +40,7 @@ import Options.Applicative.Help.Pretty (Doc) import qualified Options.Applicative.Help.Pretty as Doc import Options.Applicative.Help.Chunk import Options.Applicative.Help.Levenshtein +import qualified Options.Applicative.Internal as Internal import Prelude @@ -946,6 +955,30 @@ prop_long_command_line_flow = once $ , "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)