From b952989ad21a185a0bfed3e4f835a586d1c2dd3b Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Mon, 14 Oct 2013 17:35:07 +0100 Subject: [PATCH] Add number of columns as a preference. --- Options/Applicative/Builder.hs | 7 ++++++- Options/Applicative/Extra.hs | 4 +++- Options/Applicative/Help/Pretty.hs | 2 +- Options/Applicative/Types.hs | 14 ++++++++++---- tests/Tests.hs | 12 ++++++++---- tests/formatting.err.txt | 12 ++++++++---- 6 files changed, 36 insertions(+), 15 deletions(-) diff --git a/Options/Applicative/Builder.hs b/Options/Applicative/Builder.hs index 51f5f4ed..bd033989 100644 --- a/Options/Applicative/Builder.hs +++ b/Options/Applicative/Builder.hs @@ -83,6 +83,7 @@ module Options.Applicative.Builder ( disambiguate, showHelpOnError, noBacktrack, + columns, prefs, -- * Types @@ -357,6 +358,9 @@ showHelpOnError = PrefsMod $ \p -> p { prefShowHelpOnError = True } noBacktrack :: PrefsMod noBacktrack = PrefsMod $ \p -> p { prefBacktrack = False } +columns :: Int -> PrefsMod +columns cols = PrefsMod $ \p -> p { prefColumns = cols } + prefs :: PrefsMod -> ParserPrefs prefs m = applyPrefsMod m base where @@ -364,7 +368,8 @@ prefs m = applyPrefsMod m base { prefMultiSuffix = "" , prefDisambiguate = False , prefShowHelpOnError = False - , prefBacktrack = True } + , prefBacktrack = True + , prefColumns = 80 } -- convenience shortcuts diff --git a/Options/Applicative/Extra.hs b/Options/Applicative/Extra.hs index 9725c5d5..471e4a07 100644 --- a/Options/Applicative/Extra.hs +++ b/Options/Applicative/Extra.hs @@ -127,7 +127,9 @@ parserFailure pprefs pinfo msg ctx = ParserFailure with_context (Context n i) _ f = f n i render_help :: ParserHelp -> String - render_help = (`displayS` "") . renderPretty 1.0 80 . helpText + render_help = (`displayS` "") + . renderPretty 1.0 (prefColumns pprefs) + . helpText show_full_help = case msg of ShowHelpText -> True diff --git a/Options/Applicative/Help/Pretty.hs b/Options/Applicative/Help/Pretty.hs index 2115f0f6..ef876b62 100644 --- a/Options/Applicative/Help/Pretty.hs +++ b/Options/Applicative/Help/Pretty.hs @@ -3,7 +3,7 @@ module Options.Applicative.Help.Pretty , (.$.) ) where -import Text.PrettyPrint.ANSI.Leijen hiding ((<$>), (<>)) +import Text.PrettyPrint.ANSI.Leijen hiding ((<$>), (<>), columns) import qualified Text.PrettyPrint.ANSI.Leijen as PP (.$.) :: Doc -> Doc -> Doc diff --git a/Options/Applicative/Types.hs b/Options/Applicative/Types.hs index c8f1293b..ddddd89d 100644 --- a/Options/Applicative/Types.hs +++ b/Options/Applicative/Types.hs @@ -54,7 +54,8 @@ instance Error ParseError where -- | A full description for a runnable 'Parser' for a program. data ParserInfo a = ParserInfo { infoParser :: Parser a -- ^ the option parser for the program - , infoFullDesc :: Bool -- ^ whether the help text should contain full documentation + , infoFullDesc :: Bool -- ^ whether the help text should contain + -- full documentation , infoProgDesc :: Chunk Doc -- ^ brief parser description , infoHeader :: Chunk Doc -- ^ header of the full parser description , infoFooter :: Chunk Doc -- ^ footer of the full parser description @@ -67,9 +68,14 @@ instance Functor ParserInfo where -- | Global preferences for a top-level 'Parser'. data ParserPrefs = ParserPrefs { prefMultiSuffix :: String -- ^ metavar suffix for multiple options - , prefDisambiguate :: Bool -- ^ automatically disambiguate abbreviations (default: False) - , prefShowHelpOnError :: Bool -- ^ always show help text on parse errors (default: False) - , prefBacktrack :: Bool -- ^ backtrack to parent parser when a subcommand fails (default: True) + , prefDisambiguate :: Bool -- ^ automatically disambiguate abbreviations + -- (default: False) + , prefShowHelpOnError :: Bool -- ^ always show help text on parse errors + -- (default: False) + , prefBacktrack :: Bool -- ^ backtrack to parent parser when a + -- subcommand fails (default: True) + , prefColumns :: Int -- ^ number of columns in the terminal, used to + -- format the help page (default: 80) } data OptName = OptShort !Char diff --git a/tests/Tests.hs b/tests/Tests.hs index c79583f4..a5356f8a 100644 --- a/tests/Tests.hs +++ b/tests/Tests.hs @@ -35,15 +35,19 @@ assertHasLine l s | l `elem` lines s = return () | otherwise = assertFailure $ "expected line:\n\t" ++ l ++ "\nnot found" -checkHelpText :: Show a => String -> ParserInfo a -> [String] -> Assertion -checkHelpText name p args = do - let result = run p args +checkHelpTextWith :: Show a => ParserPrefs -> String + -> ParserInfo a -> [String] -> Assertion +checkHelpTextWith pprefs name p args = do + let result = execParserPure pprefs p args assertLeft result $ \(ParserFailure err code) -> do expected <- readFile $ "tests/" ++ name ++ ".err.txt" msg <- err name expected @=? msg ++ "\n" ExitFailure 1 @=? code +checkHelpText :: Show a => String -> ParserInfo a -> [String] -> Assertion +checkHelpText = checkHelpTextWith (prefs idm) + case_hello :: Assertion case_hello = checkHelpText "hello" Hello.opts ["--help"] @@ -330,7 +334,7 @@ case_long_help = do [ "This is a very long program description. " , "This text should be automatically wrapped " , "to fit the size of the terminal" ]) ) - checkHelpText "formatting" i ["--help"] + checkHelpTextWith (prefs (columns 50)) "formatting" i ["--help"] main :: IO () main = $(defaultMainGenerator) diff --git a/tests/formatting.err.txt b/tests/formatting.err.txt index 5915520c..f5e343d4 100644 --- a/tests/formatting.err.txt +++ b/tests/formatting.err.txt @@ -1,9 +1,13 @@ Usage: formatting [-t|--test ARG] - This is a very long program description. This text should be automatically - wrapped to fit the size of the terminal + This is a very long program description. This + text should be automatically wrapped to fit the + size of the terminal Available options: - -t,--test ARG This is an options with a very very long description. - Hopefully, this will be nicely formatted by the help + -t,--test ARG This is an options with + a very very long + description. Hopefully, + this will be nicely + formatted by the help text generator. -h,--help Show this help text