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