Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

Merge branch 'formatting'.

  • Loading branch information...
commit 73a25acffaae6ca752dfa8cf599dc46ba973b76f 2 parents 378c12c + 356758a
@pcapriotti authored
View
21 Options/Applicative/BashCompletion.hs
@@ -6,19 +6,17 @@ import Control.Applicative ((<$>), (<*>), many)
import Data.Foldable (asum)
import Data.List (isPrefixOf)
import Data.Maybe (fromMaybe, listToMaybe)
-import System.Exit (ExitCode(..))
import Options.Applicative.Builder
import Options.Applicative.Common
import Options.Applicative.Internal
import Options.Applicative.Types
-bashCompletionParser :: ParserInfo a -> ParserPrefs -> Parser ParserFailure
+bashCompletionParser :: ParserInfo a -> ParserPrefs -> Parser CompletionResult
bashCompletionParser pinfo pprefs = complParser
where
- failure opts = ParserFailure
- { errMessage = \progn -> unlines <$> opts progn
- , errExitCode = ExitSuccess }
+ failure opts = CompletionResult
+ { execCompletion = \progn -> unlines <$> opts progn }
complParser = asum
[ failure <$>
@@ -42,22 +40,27 @@ bashCompletionQuery pinfo pprefs ws i _ = case runCompletion compl pprefs of
. mapParser (\_ -> opt_completions)
opt_completions opt = case optMain opt of
- OptReader ns _ _ -> show_names ns
- FlagReader ns _ -> show_names ns
+ OptReader ns _ _ -> return $ show_names ns
+ FlagReader ns _ -> return $ show_names ns
ArgReader rdr -> run_completer (crCompleter rdr)
- CmdReader ns _ -> filter_names ns
+ CmdReader ns _ -> return $ filter_names ns
+ show_name :: OptName -> String
show_name (OptShort c) = '-':[c]
show_name (OptLong name) = "--" ++ name
+ show_names :: [OptName] -> [String]
show_names = filter_names . map show_name
- filter_names = return . filter is_completion
+
+ filter_names :: [String] -> [String]
+ filter_names = filter is_completion
run_completer :: Completer -> IO [String]
run_completer c = runCompleter c (fromMaybe "" (listToMaybe ws''))
(ws', ws'') = splitAt i ws
+ is_completion :: String -> Bool
is_completion =
case ws'' of
w:_ -> isPrefixOf w
View
53 Options/Applicative/Builder.hs
@@ -34,6 +34,7 @@ module Options.Applicative.Builder (
short,
long,
help,
+ helpDoc,
value,
showDefaultWith,
showDefault,
@@ -69,8 +70,11 @@ module Options.Applicative.Builder (
fullDesc,
briefDesc,
header,
- progDesc,
+ headerDoc,
footer,
+ footerDoc,
+ progDesc,
+ progDescDoc,
failureCode,
noIntersperse,
info,
@@ -81,6 +85,7 @@ module Options.Applicative.Builder (
disambiguate,
showHelpOnError,
noBacktrack,
+ columns,
prefs,
-- * Types
@@ -103,6 +108,8 @@ import Options.Applicative.Builder.Completer
import Options.Applicative.Builder.Internal
import Options.Applicative.Common
import Options.Applicative.Types
+import Options.Applicative.Help.Pretty
+import Options.Applicative.Help.Chunk
-- readers --
@@ -131,7 +138,7 @@ long :: HasName f => String -> Mod f a
long = fieldMod . name . OptLong
-- | Specify a default value for an option.
-value :: a -> Mod f a
+value :: HasValue f => a -> Mod f a
value x = Mod id (DefaultProp (Just x) Nothing) id
-- | Specify a function to show the default value for an option.
@@ -144,7 +151,12 @@ showDefault = showDefaultWith show
-- | Specify the help text for an option.
help :: String -> Mod f a
-help s = optionMod $ \p -> p { propHelp = s }
+help s = optionMod $ \p -> p { propHelp = paragraph s }
+
+-- | Specify the help text for an option as a 'Text.PrettyPrint.ANSI.Leijen.Doc'
+-- value.
+helpDoc :: Maybe Doc -> Mod f a
+helpDoc doc = optionMod $ \p -> p { propHelp = Chunk doc }
-- | Specify the 'Option' reader.
reader :: (String -> ReadM a) -> Mod OptionFields a
@@ -159,7 +171,7 @@ noArgError :: ParseError -> Mod OptionFields a
noArgError e = fieldMod $ \p -> p { optNoArgError = e }
-- | Specify the metavariable.
-metavar :: String -> Mod f a
+metavar :: HasMetavar f => String -> Mod f a
metavar var = optionMod $ \p -> p { propMetaVar = var }
-- | Hide this option from the brief description.
@@ -306,15 +318,30 @@ briefDesc = InfoMod $ \i -> i { infoFullDesc = False }
-- | Specify a header for this parser.
header :: String -> InfoMod a
-header s = InfoMod $ \i -> i { infoHeader = s }
+header s = InfoMod $ \i -> i { infoHeader = paragraph s }
+
+-- | Specify a header for this parser as a 'Text.PrettyPrint.ANSI.Leijen.Doc'
+-- value.
+headerDoc :: Maybe Doc -> InfoMod a
+headerDoc doc = InfoMod $ \i -> i { infoHeader = Chunk doc }
-- | Specify a footer for this parser.
footer :: String -> InfoMod a
-footer s = InfoMod $ \i -> i { infoFooter = s }
+footer s = InfoMod $ \i -> i { infoFooter = paragraph s }
+
+-- | Specify a footer for this parser as a 'Text.PrettyPrint.ANSI.Leijen.Doc'
+-- value.
+footerDoc :: Maybe Doc -> InfoMod a
+footerDoc doc = InfoMod $ \i -> i { infoFooter = Chunk doc }
-- | Specify a short program description.
progDesc :: String -> InfoMod a
-progDesc s = InfoMod $ \i -> i { infoProgDesc = s }
+progDesc s = InfoMod $ \i -> i { infoProgDesc = paragraph s }
+
+-- | Specify a short program description as a 'Text.PrettyPrint.ANSI.Leijen.Doc'
+-- value.
+progDescDoc :: Maybe Doc -> InfoMod a
+progDescDoc doc = InfoMod $ \i -> i { infoProgDesc = Chunk doc }
-- | Specify an exit code if a parse error occurs.
failureCode :: Int -> InfoMod a
@@ -331,9 +358,9 @@ info parser m = applyInfoMod m base
base = ParserInfo
{ infoParser = parser
, infoFullDesc = True
- , infoProgDesc = ""
- , infoHeader = ""
- , infoFooter = ""
+ , infoProgDesc = mempty
+ , infoHeader = mempty
+ , infoFooter = mempty
, infoFailureCode = 1
, infoIntersperse = True }
@@ -356,6 +383,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
@@ -363,7 +393,8 @@ prefs m = applyPrefsMod m base
{ prefMultiSuffix = ""
, prefDisambiguate = False
, prefShowHelpOnError = False
- , prefBacktrack = True }
+ , prefBacktrack = True
+ , prefColumns = 80 }
-- convenience shortcuts
View
21 Options/Applicative/Builder/Internal.hs
@@ -3,6 +3,8 @@ module Options.Applicative.Builder.Internal (
Mod(..),
HasName(..),
HasCompleter(..),
+ HasValue,
+ HasMetavar,
OptionFields(..),
FlagFields(..),
CommandFields(..),
@@ -62,6 +64,23 @@ instance HasCompleter OptionFields where
instance HasCompleter ArgumentFields where
modCompleter f p = p { argCompleter = f (argCompleter p) }
+class HasValue f where
+ -- this is just so that it is not necessary to specify the kind of f
+ hasValueDummy :: f a -> ()
+instance HasValue OptionFields where
+ hasValueDummy _ = ()
+instance HasValue ArgumentFields where
+ hasValueDummy _ = ()
+
+class HasMetavar f where
+ hasMetavarDummy :: f a -> ()
+instance HasMetavar OptionFields where
+ hasMetavarDummy _ = ()
+instance HasMetavar ArgumentFields where
+ hasMetavarDummy _ = ()
+instance HasMetavar CommandFields where
+ hasMetavarDummy _ = ()
+
-- mod --
data DefaultProp a = DefaultProp
@@ -118,7 +137,7 @@ baseProps :: OptProperties
baseProps = OptProperties
{ propMetaVar = ""
, propVisibility = Visible
- , propHelp = ""
+ , propHelp = mempty
, propShowDefault = Nothing }
mkCommand :: Mod CommandFields a -> ([String], String -> Maybe (ParserInfo a))
View
130 Options/Applicative/Extra.hs
@@ -10,15 +10,17 @@ module Options.Applicative.Extra (
customExecParser,
customExecParserMaybe,
execParserPure,
- usage,
ParserFailure(..),
+ ParserResult(..),
+ ParserPrefs(..),
+ CompletionResult(..),
) where
-import Control.Applicative ((<$>), (<|>), (<**>))
-import Data.Monoid (mconcat)
+import Control.Applicative (pure, (<$>), (<|>), (<**>))
+import Data.Monoid (mempty, mconcat)
import System.Environment (getArgs, getProgName)
import System.Exit (exitWith, ExitCode(..))
-import System.IO (hPutStr, stderr)
+import System.IO (hPutStrLn, stderr)
import Options.Applicative.BashCompletion
import Options.Applicative.Builder hiding (briefDesc)
@@ -27,7 +29,6 @@ import Options.Applicative.Common
import Options.Applicative.Help
import Options.Applicative.Internal
import Options.Applicative.Types
-import Options.Applicative.Utils
-- | A hidden \"helper\" option which always fails.
helper :: Parser (a -> a)
@@ -57,15 +58,19 @@ customExecParser :: ParserPrefs -> ParserInfo a -> IO a
customExecParser pprefs pinfo = do
args <- getArgs
case execParserPure pprefs pinfo args of
- Right a -> return a
- Left failure -> do
+ Success a -> return a
+ Failure failure -> do
progn <- getProgName
- let c = errExitCode failure
- msg <- errMessage failure progn
- case c of
- ExitSuccess -> putStr msg
- _ -> hPutStr stderr msg
- exitWith c
+ let (msg, exit) = execFailure failure progn
+ case exit of
+ ExitSuccess -> putStrLn msg
+ _ -> hPutStrLn stderr msg
+ exitWith exit
+ CompletionInvoked compl -> do
+ progn <- getProgName
+ msg <- execCompletion compl progn
+ putStr msg
+ exitWith ExitSuccess
-- | Run a program description in pure code.
--
@@ -81,73 +86,39 @@ execParserMaybe = customExecParserMaybe (prefs idm)
--
-- See 'execParserMaybe' for details.
customExecParserMaybe :: ParserPrefs -> ParserInfo a -> [String] -> Maybe a
-customExecParserMaybe pprefs pinfo
- = either (const Nothing) Just
- . execParserPure pprefs pinfo
-
-data Result a = Result a
- | Extra ParserFailure
+customExecParserMaybe pprefs pinfo args = case execParserPure pprefs pinfo args of
+ Success r -> Just r
+ _ -> Nothing
-- | The most general way to run a program description in pure code.
execParserPure :: ParserPrefs -- ^ Global preferences for this parser
-> ParserInfo a -- ^ Description of the program to run
-> [String] -- ^ Program arguments
- -> Either ParserFailure a
+ -> ParserResult a
execParserPure pprefs pinfo args =
case runP p pprefs of
- (Right r, _) -> case r of
- Result a -> Right a
- Extra failure -> Left failure
- (Left msg, ctx) -> Left $
- parserFailure pprefs pinfo msg ctx
+ (Right (Right r), _) -> Success r
+ (Right (Left c), _) -> CompletionInvoked c
+ (Left err, ctx) -> Failure $ parserFailure pprefs pinfo err ctx
where
pinfo' = pinfo
- { infoParser = (Extra <$> bashCompletionParser pinfo pprefs)
- <|> (Result <$> infoParser pinfo) }
+ { infoParser = (Left <$> bashCompletionParser pinfo pprefs)
+ <|> (Right <$> infoParser pinfo) }
p = runParserInfo pinfo' args
parserFailure :: ParserPrefs -> ParserInfo a
-> ParseError -> Context
-> ParserFailure
-parserFailure pprefs pinfo msg ctx = ParserFailure
- { errMessage = \progn
- -> with_context ctx pinfo $ \names ->
- return
- . show_help
- . add_error
- . add_usage names progn
- , errExitCode = exit_code }
+parserFailure pprefs pinfo msg ctx = ParserFailure $ \progn ->
+ let h = with_context ctx pinfo $ \names pinfo' -> mconcat
+ [ base_help pinfo'
+ , usage_help progn names pinfo'
+ , error_help ]
+ in (render_help h, exit_code)
where
- add_usage names progn i = case msg of
- InfoMsg _ -> i
- _ -> i
- { infoHeader = vcat
- ( header_line i ++
- [ usage pprefs (infoParser i) ename ] ) }
- where
- ename = unwords (progn : names)
- add_error i = i
- { infoHeader = vcat (error_msg ++ [infoHeader i]) }
- error_msg = case msg of
- ShowHelpText -> []
- ErrorMsg m -> [m]
- InfoMsg m -> [m]
exit_code = case msg of
InfoMsg _ -> ExitSuccess
_ -> ExitFailure (infoFailureCode pinfo)
- show_full_help = case msg of
- ShowHelpText -> True
- _ -> prefShowHelpOnError pprefs
- show_help i
- | show_full_help
- = parserHelpText pprefs i
- | otherwise
- = unlines $ filter (not . null) [ infoHeader i ]
- header_line i
- | show_full_help
- = [ infoHeader i ]
- | otherwise
- = []
with_context :: Context
-> ParserInfo a
@@ -156,9 +127,32 @@ parserFailure pprefs pinfo msg ctx = ParserFailure
with_context NullContext i f = f [] i
with_context (Context n i) _ f = f n i
--- | Generate option summary.
-usage :: ParserPrefs -> Parser a -> String -> String
-usage pprefs p progn = foldr (<+>) ""
- [ "Usage:"
- , progn
- , briefDesc pprefs p ]
+ render_help :: ParserHelp -> String
+ render_help = (`displayS` "")
+ . renderPretty 1.0 (prefColumns pprefs)
+ . helpText
+
+ show_full_help = case msg of
+ ShowHelpText -> True
+ _ -> prefShowHelpOnError pprefs
+
+ usage_help progn names i = case msg of
+ InfoMsg _ -> mempty
+ _ -> usageHelp $ vcatChunks
+ [ pure . parserUsage pprefs (infoParser i) . unwords $ progn : names
+ , fmap (indent 2) . infoProgDesc $ i ]
+
+ error_help = headerHelp $ case msg of
+ ShowHelpText -> mempty
+ ErrorMsg m -> stringChunk m
+ InfoMsg m -> stringChunk m
+
+ base_help :: ParserInfo a -> ParserHelp
+ base_help i
+ | show_full_help
+ = mconcat [h, f, parserHelp pprefs (infoParser i)]
+ | otherwise
+ = h
+ where
+ h = headerHelp (infoHeader i)
+ f = footerHelp (infoFooter i)
View
116 Options/Applicative/Help.hs
@@ -1,115 +1,7 @@
module Options.Applicative.Help (
- cmdDesc,
- briefDesc,
- fullDesc,
- parserHelpText,
+ module X
) where
-import Data.List (intercalate, sort)
-import Data.Maybe (maybeToList, catMaybes)
-
-import Options.Applicative.Common
-import Options.Applicative.Types
-import Options.Applicative.Utils
-
--- | Style for rendering an option.
-data OptDescStyle = OptDescStyle
- { descSep :: String
- , descHidden :: Bool
- , descSurround :: Bool }
-
--- | Generate description for a single option.
-optDesc :: ParserPrefs -> OptDescStyle -> OptHelpInfo -> Option a -> String
-optDesc pprefs style info opt =
- let ns = optionNames $ optMain opt
- mv = optMetaVar opt
- descs = map showOption (sort ns)
- desc' = intercalate (descSep style) descs <+> mv
- show_opt
- | optVisibility opt == Hidden
- = descHidden style
- | otherwise
- = optVisibility opt == Visible
- suffix
- | hinfoMulti info
- = prefMultiSuffix pprefs
- | otherwise
- = ""
- render text
- | not show_opt
- = ""
- | null text || not (descSurround style)
- = text ++ suffix
- | hinfoDefault info
- = "[" ++ text ++ "]" ++ suffix
- | null (drop 1 descs)
- = text ++ suffix
- | otherwise
- = "(" ++ text ++ ")" ++ suffix
- in render desc'
-
--- | Generate descriptions for commands.
-cmdDesc :: Parser a -> [String]
-cmdDesc = concat . mapParser desc
- where
- desc _ opt =
- case optMain opt of
- CmdReader cmds p ->
- tabulate [(cmd, d)
- | cmd <- reverse cmds
- , d <- maybeToList . fmap infoProgDesc $ p cmd ]
- _ -> []
-
--- | Generate a brief help text for a parser.
-briefDesc :: ParserPrefs -> Parser a -> String
-briefDesc pprefs = fold_tree . treeMapParser (optDesc pprefs style)
- where
- style = OptDescStyle
- { descSep = "|"
- , descHidden = False
- , descSurround = True }
-
- fold_tree (Leaf x) = x
- fold_tree (MultNode xs) = unwords (fold_trees xs)
- fold_tree (AltNode xs) = alt_node (fold_trees xs)
-
- alt_node [n] = n
- alt_node ns = "(" ++ intercalate " | " ns ++ ")"
-
- fold_trees = filter (not . null) . map fold_tree
-
--- | Generate a full help text for a parser.
-fullDesc :: ParserPrefs -> Parser a -> [String]
-fullDesc pprefs = tabulate . catMaybes . mapParser doc
- where
- doc info opt
- | null n = Nothing
- | null h = Nothing
- | otherwise = Just (n, h ++ hdef)
- where n = optDesc pprefs style info opt
- h = optHelp opt
- hdef = maybe "" show_def (optShowDefault opt)
- show_def s = " (default: " ++ s ++ ")"
- style = OptDescStyle
- { descSep = ","
- , descHidden = True
- , descSurround = False }
-
--- | Generate the help text for a program.
-parserHelpText :: ParserPrefs -> ParserInfo a -> String
-parserHelpText pprefs pinfo = unlines
- $ nn [infoHeader pinfo]
- ++ [ " " ++ line | line <- nn [infoProgDesc pinfo] ]
- ++ [ line | let opts = fullDesc pprefs p
- , not (null opts)
- , line <- ["", "Available options:"] ++ opts
- , infoFullDesc pinfo ]
- ++ [ line | let cmds = cmdDesc p
- , not (null cmds)
- , line <- ["", "Available commands:"] ++ cmds
- , infoFullDesc pinfo ]
- ++ [ line | footer <- nn [infoFooter pinfo]
- , line <- ["", footer] ]
- where
- nn = filter (not . null)
- p = infoParser pinfo
+import Options.Applicative.Help.Pretty as X
+import Options.Applicative.Help.Chunk as X
+import Options.Applicative.Help.Core as X
View
135 Options/Applicative/Help/Chunk.hs
@@ -0,0 +1,135 @@
+module Options.Applicative.Help.Chunk
+ ( mappendWith
+ , Chunk(..)
+ , chunked
+ , listToChunk
+ , (<<+>>)
+ , (<</>>)
+ , vcatChunks
+ , vsepChunks
+ , isEmpty
+ , stringChunk
+ , paragraph
+ , extractChunk
+ , tabulate
+ ) where
+
+import Control.Applicative
+import Control.Monad
+import Data.Maybe
+import Data.Monoid hiding ((<>))
+
+import Options.Applicative.Help.Pretty
+
+mappendWith :: Monoid a => a -> a -> a -> a
+mappendWith s x y = mconcat [x, s, y]
+
+-- | The free monoid on a semigroup 'a'.
+newtype Chunk a = Chunk
+ { unChunk :: Maybe a }
+ deriving (Eq, Show)
+
+instance Functor Chunk where
+ fmap f = Chunk . fmap f . unChunk
+
+instance Applicative Chunk where
+ pure = Chunk . pure
+ Chunk f <*> Chunk x = Chunk (f <*> x)
+
+instance Monad Chunk where
+ return = pure
+ m >>= f = Chunk $ unChunk m >>= unChunk . f
+
+instance MonadPlus Chunk where
+ 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'.
+--
+-- Note that this is /not/ the same as 'liftA2'.
+chunked :: (a -> a -> a)
+ -> Chunk a -> Chunk a -> Chunk a
+chunked _ (Chunk Nothing) y = y
+chunked _ x (Chunk Nothing) = x
+chunked f (Chunk (Just x)) (Chunk (Just y)) = Chunk (Just (f x y))
+
+-- | Concatenate a list into a Chunk. 'listToChunk' satisfies:
+--
+-- > isEmpty . listToChunk = null
+-- > listToChunk = mconcat . fmap pure
+listToChunk :: Monoid a => [a] -> Chunk a
+listToChunk [] = mempty
+listToChunk xs = pure (mconcat xs)
+
+instance Monoid a => Monoid (Chunk a) where
+ mempty = Chunk Nothing
+ mappend = chunked mappend
+
+-- | Part of a constrained comonad instance.
+--
+-- This is the counit of the adjunction between 'Chunk' and the forgetful
+-- functor from monoids to semigroups. It satisfies:
+--
+-- > extractChunk . pure = id
+-- > extractChunk . fmap pure = id
+extractChunk :: Monoid a => Chunk a -> a
+extractChunk = fromMaybe mempty . unChunk
+-- we could also define:
+-- duplicate :: Monoid a => Chunk a -> Chunk (Chunk a)
+-- duplicate = fmap pure
+
+-- | Concatenate two 'Chunk's with a space in between. If one is empty, this
+-- just returns the other one.
+--
+-- Unlike '<+>' for 'Doc', this operation has a unit element, namely the empty
+-- 'Chunk'.
+(<<+>>) :: Chunk Doc -> Chunk Doc -> Chunk Doc
+(<<+>>) = chunked (<+>)
+
+-- | Concatenate two 'Chunk's with a softline in between. This is exactly like
+-- '<<+>>', but uses a softline instead of a space.
+(<</>>) :: Chunk Doc -> Chunk Doc -> Chunk Doc
+(<</>>) = chunked (</>)
+
+-- | Concatenate 'Chunk's vertically.
+vcatChunks :: [Chunk Doc] -> Chunk Doc
+vcatChunks = foldr (chunked (.$.)) mempty
+
+-- | Concatenate 'Chunk's vertically separated by empty lines.
+vsepChunks :: [Chunk Doc] -> Chunk Doc
+vsepChunks = foldr (chunked (\x y -> x .$. mempty .$. y)) mempty
+
+-- | Whether a 'Chunk' is empty. Note that something like 'pure mempty' is not
+-- considered an empty chunk, even though the underlying 'Doc' is empty.
+isEmpty :: Chunk a -> Bool
+isEmpty = isNothing . unChunk
+
+-- | Convert a 'String' into a 'Chunk'. This satisfies:
+--
+-- > isEmpty . stringChunk = null
+-- > extractChunk . stringChunk = string
+stringChunk :: String -> Chunk Doc
+stringChunk "" = mempty
+stringChunk s = pure (string s)
+
+-- | Convert a paragraph into a 'Chunk'. The resulting chunk is composed by the
+-- words of the original paragraph separated by softlines, so it will be
+-- automatically word-wrapped when rendering the underlying document.
+--
+-- This satisfies:
+--
+-- > isEmpty . paragraph = null . words
+paragraph :: String -> Chunk Doc
+paragraph = foldr (chunked (</>)) mempty
+ . map stringChunk
+ . words
+
+tabulate' :: Int -> [(Doc, Doc)] -> Chunk Doc
+tabulate' _ [] = mempty
+tabulate' size table = pure $ vcat
+ [ indent 2 (fillBreak size key <+> value)
+ | (key, value) <- table ]
+
+-- | Display pairs of strings in a table.
+tabulate :: [(Doc, Doc)] -> Chunk Doc
+tabulate = tabulate' 24
View
153 Options/Applicative/Help/Core.hs
@@ -0,0 +1,153 @@
+module Options.Applicative.Help.Core (
+ cmdDesc,
+ briefDesc,
+ fullDesc,
+ ParserHelp(..),
+ helpText,
+ headerHelp,
+ usageHelp,
+ bodyHelp,
+ footerHelp,
+ parserHelp,
+ parserUsage,
+ ) where
+
+import Control.Monad (guard)
+import Data.List (intersperse, sort)
+import Data.Maybe (maybeToList, catMaybes)
+import Data.Monoid (Monoid, mempty, mappend, mconcat)
+
+import Options.Applicative.Common
+import Options.Applicative.Types
+import Options.Applicative.Help.Pretty
+import Options.Applicative.Help.Chunk
+
+-- | Style for rendering an option.
+data OptDescStyle = OptDescStyle
+ { descSep :: Doc
+ , descHidden :: Bool
+ , descSurround :: Bool }
+
+-- | Generate description for a single option.
+optDesc :: ParserPrefs -> OptDescStyle -> OptHelpInfo -> Option a -> Chunk Doc
+optDesc pprefs style info opt =
+ let ns = optionNames $ optMain opt
+ mv = stringChunk $ optMetaVar opt
+ descs = map (string . showOption) (sort ns)
+ desc' = listToChunk (intersperse (descSep style) descs) <<+>> mv
+ show_opt
+ | optVisibility opt == Hidden
+ = descHidden style
+ | otherwise
+ = optVisibility opt == Visible
+ suffix
+ | hinfoMulti info
+ = stringChunk . prefMultiSuffix $ pprefs
+ | otherwise
+ = mempty
+ render chunk
+ | not show_opt
+ = mempty
+ | isEmpty chunk || not (descSurround style)
+ = mappend chunk suffix
+ | hinfoDefault info
+ = mappend (fmap brackets chunk) suffix
+ | null (drop 1 descs)
+ = mappend chunk suffix
+ | otherwise
+ = mappend (fmap parens chunk) suffix
+ in render desc'
+
+-- | Generate descriptions for commands.
+cmdDesc :: Parser a -> Chunk Doc
+cmdDesc = mconcat . mapParser desc
+ where
+ desc _ opt =
+ case optMain opt of
+ CmdReader cmds p ->
+ tabulate [(string cmd, align (extractChunk d))
+ | cmd <- reverse cmds
+ , d <- maybeToList . fmap infoProgDesc $ p cmd ]
+ _ -> mempty
+
+-- | Generate a brief help text for a parser.
+briefDesc :: ParserPrefs -> Parser a -> Chunk Doc
+briefDesc pprefs = fold_tree . treeMapParser (optDesc pprefs style)
+ where
+ style = OptDescStyle
+ { descSep = string "|"
+ , descHidden = False
+ , descSurround = True }
+
+ fold_tree (Leaf x) = x
+ fold_tree (MultNode xs) = foldr (<</>>) mempty . map fold_tree $ xs
+ fold_tree (AltNode xs) = alt_node
+ . filter (not . isEmpty)
+ . map fold_tree $ xs
+
+ alt_node :: [Chunk Doc] -> Chunk Doc
+ alt_node [n] = n
+ alt_node ns = fmap parens
+ . foldr (chunked (\x y -> x </> char '|' </> y)) mempty
+ $ ns
+
+-- | Generate a full help text for a parser.
+fullDesc :: ParserPrefs -> Parser a -> Chunk Doc
+fullDesc pprefs = tabulate . catMaybes . mapParser doc
+ where
+ doc info opt = do
+ guard . not . isEmpty $ n
+ guard . not . isEmpty $ h
+ return (extractChunk n, align . extractChunk $ h <<+>> hdef)
+ where
+ n = optDesc pprefs style info opt
+ h = optHelp $ opt
+ hdef = Chunk . fmap show_def . optShowDefault $ opt
+ show_def s = parens (string "default:" <+> string s)
+ style = OptDescStyle
+ { descSep = string ","
+ , descHidden = True
+ , descSurround = False }
+
+data ParserHelp = ParserHelp
+ { helpHeader :: Chunk Doc
+ , helpUsage :: Chunk Doc
+ , helpBody :: Chunk Doc
+ , helpFooter :: Chunk Doc }
+
+instance Monoid ParserHelp where
+ mempty = ParserHelp mempty mempty mempty mempty
+ mappend (ParserHelp h1 u1 b1 f1) (ParserHelp h2 u2 b2 f2)
+ = ParserHelp (mappend h1 h2) (mappend u1 u2)
+ (mappend b1 b2) (mappend f1 f2)
+
+headerHelp :: Chunk Doc -> ParserHelp
+headerHelp chunk = ParserHelp chunk mempty mempty mempty
+
+usageHelp :: Chunk Doc -> ParserHelp
+usageHelp chunk = ParserHelp mempty chunk mempty mempty
+
+bodyHelp :: Chunk Doc -> ParserHelp
+bodyHelp chunk = ParserHelp mempty mempty chunk mempty
+
+footerHelp :: Chunk Doc -> ParserHelp
+footerHelp chunk = ParserHelp mempty mempty mempty chunk
+
+helpText :: ParserHelp -> Doc
+helpText (ParserHelp h u b f) = extractChunk . vsepChunks $ [h, u, b, f]
+
+-- | Generate the help text for a program.
+parserHelp :: ParserPrefs -> Parser a -> ParserHelp
+parserHelp pprefs p = bodyHelp . vsepChunks $
+ [ with_title "Available options:" (fullDesc pprefs p)
+ , with_title "Available commands:" (cmdDesc p) ]
+ where
+ with_title :: String -> Chunk Doc -> Chunk Doc
+ with_title title = fmap (string title .$.)
+
+-- | Generate option summary.
+parserUsage :: ParserPrefs -> Parser a -> String -> Doc
+parserUsage pprefs p progn = hsep $
+ [ string "Usage:"
+ , string progn
+ , align (extractChunk (briefDesc pprefs p)) ]
View
10 Options/Applicative/Help/Pretty.hs
@@ -0,0 +1,10 @@
+module Options.Applicative.Help.Pretty
+ ( module Text.PrettyPrint.ANSI.Leijen
+ , (.$.)
+ ) where
+
+import Text.PrettyPrint.ANSI.Leijen hiding ((<$>), (<>), columns)
+import qualified Text.PrettyPrint.ANSI.Leijen as PP
+
+(.$.) :: Doc -> Doc -> Doc
+(.$.) = (PP.<$>)
View
49 Options/Applicative/Types.hs
@@ -17,7 +17,9 @@ module Options.Applicative.Types (
ParserM(..),
Completer(..),
mkCompleter,
+ CompletionResult(..),
ParserFailure(..),
+ ParserResult(..),
OptHelpInfo(..),
OptTree(..),
@@ -39,6 +41,9 @@ import Control.Monad.Trans.Error (Error(..))
import Data.Monoid (Monoid(..))
import System.Exit (ExitCode(..))
+import Options.Applicative.Help.Pretty
+import Options.Applicative.Help.Chunk
+
data ParseError
= ErrorMsg String
| InfoMsg String
@@ -50,15 +55,15 @@ 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
- , infoProgDesc :: String -- ^ brief parser description
- , infoHeader :: String -- ^ header of the full parser description
- , infoFooter :: String -- ^ footer of the full parser description
- , infoFailureCode :: Int -- ^ exit code for a parser failure
- , infoIntersperse :: Bool -- ^ allow regular options and flags to occur after
- -- arguments (default: True)
+ { infoParser :: Parser a -- ^ the option parser for the program
+ , 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
+ , infoFailureCode :: Int -- ^ exit code for a parser failure
+ , infoIntersperse :: Bool -- ^ allow regular options and flags to occur
+ -- after arguments (default: True)
}
instance Functor ParserInfo where
@@ -73,6 +78,8 @@ data ParserPrefs = ParserPrefs
-- (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
@@ -89,7 +96,7 @@ data OptVisibility
-- | Specification for an individual parser option.
data OptProperties = OptProperties
{ propVisibility :: OptVisibility -- ^ whether this flag is shown is the brief description
- , propHelp :: String -- ^ help text for this option
+ , propHelp :: Chunk Doc -- ^ help text for this option
, propMetaVar :: String -- ^ metavariable for this option
, propShowDefault :: Maybe String -- ^ what to show in the help text as the default
}
@@ -222,17 +229,17 @@ instance Monoid Completer where
mappend (Completer c1) (Completer c2) =
Completer $ \s -> (++) <$> c1 s <*> c2 s
--- | Result after a parse error.
-data ParserFailure = ParserFailure
- { errMessage :: String -> IO String -- ^ Function which takes the program name
- -- as input and returns an error message
- , errExitCode :: ExitCode -- ^ Exit code to use for this error
- }
+newtype CompletionResult = CompletionResult
+ { execCompletion :: String -> IO String }
+
+newtype ParserFailure = ParserFailure
+ { execFailure :: String -> (String, ExitCode) }
-instance Error ParserFailure where
- strMsg msg = ParserFailure
- { errMessage = \_ -> return msg
- , errExitCode = ExitFailure 1 }
+-- | Result of 'execParserPure'.
+data ParserResult a
+ = Success a
+ | Failure ParserFailure
+ | CompletionInvoked CompletionResult
data OptHelpInfo = OptHelpInfo
{ hinfoMulti :: Bool
@@ -247,7 +254,7 @@ data OptTree a
optVisibility :: Option a -> OptVisibility
optVisibility = propVisibility . optProps
-optHelp :: Option a -> String
+optHelp :: Option a -> Chunk Doc
optHelp = propHelp . optProps
optMetaVar :: Option a -> String
View
32 Options/Applicative/Utils.hs
@@ -1,32 +0,0 @@
-module Options.Applicative.Utils (
- (<+>),
- vcat,
- tabulate,
- pad
- ) where
-
-import Data.List (intercalate)
-
--- | Concatenate two strings with a space in the middle.
-(<+>) :: String -> String -> String
-"" <+> s = s
-s <+> "" = s
-s1 <+> s2 = s1 ++ " " ++ s2
-
--- | Concatenate strings vertically with empty lines in between.
-vcat :: [String] -> String
-vcat = intercalate "\n\n" . filter (not . null)
-
-tabulate' :: Int -> [(String, String)] -> [String]
-tabulate' size table =
- [ " " ++ pad size key ++ " " ++ value
- | (key, value) <- table ]
-
--- | Display pairs of strings in a table.
-tabulate :: [(String, String)] -> [String]
-tabulate = tabulate' 24
-
--- | Pad a string to a fixed size with whitespace.
-pad :: Int -> String -> String
-pad size str = str ++ replicate (size - n `max` 0) ' '
- where n = length str
View
13 optparse-applicative.cabal
@@ -96,21 +96,26 @@ library
Options.Applicative.Common,
Options.Applicative.Extra,
Options.Applicative.Help,
- Options.Applicative.Types,
- Options.Applicative.Utils
+ Options.Applicative.Help.Pretty,
+ Options.Applicative.Help.Chunk,
+ Options.Applicative.Help.Core,
+ Options.Applicative.Types
other-modules: Options.Applicative.Internal
ghc-options: -Wall
build-depends: base == 4.*,
transformers >= 0.2 && < 0.4,
- process >= 1.0 && < 1.3
+ process >= 1.0 && < 1.3,
+ ansi-wl-pprint >= 0.6 && < 0.7
test-suite tests
type: exitcode-stdio-1.0
hs-source-dirs: tests
main-is: Tests.hs
- ghc-options: -Wall
+ ghc-options: -Wall -fno-warn-orphans
build-depends: base == 4.*,
HUnit == 1.2.*,
optparse-applicative,
+ QuickCheck == 2.6.*,
test-framework >= 0.6 && < 0.9,
test-framework-hunit >= 0.2 && < 0.4,
+ test-framework-quickcheck2 == 0.3.*,
test-framework-th-prime == 0.0.*
View
3  tests/Examples/Cabal.hs
@@ -118,7 +118,8 @@ buildOpts = runA $ proc () -> do
returnA -< BuildOpts bdir
pinfo :: ParserInfo Args
-pinfo = info parser idm
+pinfo = info parser
+ ( progDesc "An example modelled on cabal" )
main :: IO ()
main = do
View
12 tests/Examples/Formatting.hs
@@ -0,0 +1,12 @@
+module Examples.Formatting where
+
+import Data.Monoid
+import Options.Applicative
+
+opts :: Parser Int
+opts = option $ mconcat
+ [ long "test"
+ , short 't'
+ , value 0
+ , metavar "FOO_BAR_BAZ_LONG_METAVARIABLE"
+ , help "This is an options with a very very long description. Hopefully, this will be nicely formatted by the help text generator." ]
View
220 tests/Tests.hs
@@ -1,18 +1,29 @@
-{-# LANGUAGE TemplateHaskell, CPP #-}
+{-# LANGUAGE StandaloneDeriving, GeneralizedNewtypeDeriving,
+ TemplateHaskell, CPP #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
module Main where
import qualified Examples.Hello as Hello
import qualified Examples.Commands as Commands
import qualified Examples.Cabal as Cabal
import qualified Examples.Alternatives as Alternatives
+import qualified Examples.Formatting as Formatting
import Control.Monad
-import Data.List
-import Options.Applicative
+import Data.List hiding (group)
+import Data.Monoid
import System.Exit
import Test.HUnit
import Test.Framework.Providers.HUnit
+import Test.Framework.Providers.QuickCheck2 (testProperty)
import Test.Framework.TH.Prime
+import Test.QuickCheck (Positive (..))
+import Test.QuickCheck.Arbitrary
+
+import Options.Applicative
+import Options.Applicative.Help.Pretty (Doc, SimpleDoc(..))
+import qualified Options.Applicative.Help.Pretty as Doc
+import Options.Applicative.Help.Chunk
#if __GLASGOW_HASKELL__ <= 702
import Data.Monoid
@@ -20,35 +31,41 @@ import Data.Monoid
(<>) = mappend
#endif
-run :: ParserInfo a -> [String] -> Either ParserFailure a
+run :: ParserInfo a -> [String] -> ParserResult a
run = execParserPure (prefs idm)
-assertLeft :: Show b => Either a b -> (a -> Assertion) -> Assertion
-assertLeft x f = either f err x
- where
- err b = assertFailure $ "expected Left, got " ++ show b
+assertError :: Show a => ParserResult a -> (ParserFailure -> Assertion) -> Assertion
+assertError x f = case x of
+ Success r -> assertFailure $ "expected failure, got success: " ++ show r
+ Failure e -> f e
+ CompletionInvoked _ -> assertFailure $ "expected failure, got completion"
-assertRight :: Either ParserFailure b -> (b -> Assertion) -> Assertion
-assertRight x f = either err f x
- where
- err (ParserFailure e _) = do
- msg <- e "test"
- assertFailure $ "unexpected parse error\n" ++ msg
+assertResult :: ParserResult a -> (a -> Assertion) -> Assertion
+assertResult x f = case x of
+ Success r -> f r
+ Failure e -> do
+ let (msg, _) = execFailure e "test"
+ assertFailure $ "unexpected parse error\n" ++ msg
+ CompletionInvoked _ -> assertFailure $ "expected result, got completion"
assertHasLine :: String -> String -> Assertion
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
- assertLeft result $ \(ParserFailure err code) -> do
+checkHelpTextWith :: Show a => ParserPrefs -> String
+ -> ParserInfo a -> [String] -> Assertion
+checkHelpTextWith pprefs name p args = do
+ let result = execParserPure pprefs p args
+ assertError result $ \(ParserFailure err) -> do
expected <- readFile $ "tests/" ++ name ++ ".err.txt"
- msg <- err name
- expected @=? msg
+ let (msg, code) = 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"]
@@ -62,42 +79,41 @@ case_args :: Assertion
case_args = do
let result = run Commands.opts ["hello", "foo", "bar"]
case result of
- Left _ ->
- assertFailure "unexpected parse error"
- Right (Commands.Hello args) ->
+ Success (Commands.Hello args) ->
["foo", "bar"] @=? args
- Right Commands.Goodbye ->
+ Success Commands.Goodbye ->
assertFailure "unexpected result: Goodbye"
+ _ ->
+ assertFailure "unexpected parse error"
case_args_opts :: Assertion
case_args_opts = do
let result = run Commands.opts ["hello", "foo", "--bar"]
case result of
- Left _ -> return ()
- Right (Commands.Hello xs) ->
+ Success (Commands.Hello xs) ->
assertFailure $ "unexpected result: Hello " ++ show xs
- Right Commands.Goodbye ->
+ Success Commands.Goodbye ->
assertFailure "unexpected result: Goodbye"
+ _ -> return ()
case_args_ddash :: Assertion
case_args_ddash = do
let result = run Commands.opts ["hello", "foo", "--", "--bar", "baz"]
case result of
- Left _ ->
- assertFailure "unexpected parse error"
- Right (Commands.Hello args) ->
+ Success (Commands.Hello args) ->
["foo", "--bar", "baz"] @=? args
- Right Commands.Goodbye ->
+ Success Commands.Goodbye ->
assertFailure "unexpected result: Goodbye"
+ _ -> assertFailure "unexpected parse error"
case_alts :: Assertion
case_alts = do
let result = run Alternatives.opts ["-b", "-a", "-b", "-a", "-a", "-b"]
case result of
- Left _ -> assertFailure "unexpected parse error"
- Right xs -> [b, a, b, a, a, b] @=? xs
+ Success xs -> [b, a, b, a, a, b] @=? xs
where a = Alternatives.A
b = Alternatives.B
+ _ -> assertFailure "unexpected parse error"
case_show_default :: Assertion
case_show_default = do
@@ -108,12 +124,13 @@ case_show_default = do
i = info (p <**> helper) idm
result = run i ["--help"]
case result of
- Left (ParserFailure err _) -> do
- msg <- err "test"
+ Failure (ParserFailure err) -> do
+ let (msg, _) = err "test"
assertHasLine
" -n ARG set count (default: 0)"
msg
- Right r -> assertFailure $ "unexpected result: " ++ show r
+ Success r -> assertFailure $ "unexpected result: " ++ show r
+ CompletionInvoked _ -> assertFailure "unexpected completion"
case_alt_cont :: Assertion
case_alt_cont = do
@@ -121,8 +138,8 @@ case_alt_cont = do
i = info p idm
result = run i ["-a", "-b"]
case result of
- Left _ -> return ()
- Right r -> assertFailure $ "unexpected result: " ++ show r
+ Success r -> assertFailure $ "unexpected result: " ++ show r
+ _ -> return ()
case_alt_help :: Assertion
case_alt_help = do
@@ -154,8 +171,8 @@ case_many_args = do
nargs = 20000
result = run i (replicate nargs "foo")
case result of
- Left _ -> assertFailure "unexpected parse error"
- Right xs -> nargs @=? length xs
+ Success xs -> nargs @=? length xs
+ _ -> assertFailure "unexpected parse error"
case_disambiguate :: Assertion
case_disambiguate = do
@@ -165,8 +182,8 @@ case_disambiguate = do
i = info p idm
result = execParserPure (prefs disambiguate) i ["--f"]
case result of
- Left _ -> assertFailure "unexpected parse error"
- Right val -> 1 @=? val
+ Success val -> 1 @=? val
+ _ -> assertFailure "unexpected parse error"
case_ambiguous :: Assertion
case_ambiguous = do
@@ -176,8 +193,8 @@ case_ambiguous = do
i = info p idm
result = execParserPure (prefs disambiguate) i ["--ba"]
case result of
- Left _ -> return ()
- Right val -> assertFailure $ "unexpected result " ++ show val
+ Success val -> assertFailure $ "unexpected result " ++ show val
+ _ -> return ()
case_completion :: Assertion
case_completion = do
@@ -187,12 +204,11 @@ case_completion = do
i = info p idm
result = run i ["--bash-completion-index", "0"]
case result of
- Left (ParserFailure err code) -> do
- ExitSuccess @=? code
+ CompletionInvoked (CompletionResult err) -> do
completions <- lines <$> err "test"
["--foo", "--bar"] @=? completions
- Right val ->
- assertFailure $ "unexpected result " ++ show val
+ Failure _ -> assertFailure "unexpected failure"
+ Success val -> assertFailure $ "unexpected result " ++ show val
case_bind_usage :: Assertion
case_bind_usage = do
@@ -200,11 +216,12 @@ case_bind_usage = do
i = info (p <**> helper) briefDesc
result = run i ["--help"]
case result of
- Left (ParserFailure err _) -> do
- text <- head . lines <$> err "test"
+ Failure (ParserFailure err) -> do
+ let text = head . lines . fst $ err "test"
"Usage: test [ARGS...]" @=? text
- Right val ->
+ Success val ->
assertFailure $ "unexpected result " ++ show val
+ CompletionInvoked _ -> assertFailure "unexpected completion"
case_issue_19 :: Assertion
case_issue_19 = do
@@ -215,15 +232,15 @@ case_issue_19 = do
i = info (p <**> helper) idm
result = run i ["-x", "foo"]
case result of
- Left _ -> assertFailure "unexpected parse error"
- Right r -> Just "foo" @=? r
+ Success r -> Just "foo" @=? r
+ _ -> assertFailure "unexpected parse error"
case_arguments1_none :: Assertion
case_arguments1_none = do
let p = some (argument str idm)
i = info (p <**> helper) idm
result = run i []
- assertLeft result $ \(ParserFailure _ _) -> return ()
+ assertError result $ \(ParserFailure _) -> return ()
case_arguments1_some :: Assertion
case_arguments1_some = do
@@ -231,8 +248,8 @@ case_arguments1_some = do
i = info (p <**> helper) idm
result = run i ["foo", "--", "bar", "baz"]
case result of
- Left _ -> assertFailure "unexpected parse error"
- Right r -> ["foo", "bar", "baz"] @=? r
+ Success r -> ["foo", "bar", "baz"] @=? r
+ _ -> assertFailure "unexpected parse error"
case_arguments_switch :: Assertion
case_arguments_switch = do
@@ -240,7 +257,7 @@ case_arguments_switch = do
*> many (argument str idm)
i = info p idm
result = run i ["--", "-x"]
- assertRight result $ \args -> ["-x"] @=? args
+ assertResult result $ \args -> ["-x"] @=? args
case_issue_35 :: Assertion
case_issue_35 = do
@@ -248,12 +265,9 @@ case_issue_35 = do
<|> flag' False (short 'f')
i = info p idm
result = run i []
- case result of
- Left (ParserFailure err _) -> do
- text <- head . lines <$> err "test"
- "Usage: test -f" @=? text
- Right val ->
- assertFailure $ "unexpected result " ++ show val
+ assertError result $ \(ParserFailure err) -> do
+ let text = head . lines . fst . err $ "test"
+ "Usage: test -f" @=? text
case_backtracking :: Assertion
case_backtracking = do
@@ -263,7 +277,7 @@ case_backtracking = do
<*> switch (short 'b')
i = info (p1 <**> helper) idm
result = execParserPure (prefs noBacktrack) i ["c", "-b"]
- assertLeft result $ \ _ -> return ()
+ assertError result $ \ _ -> return ()
case_error_context :: Assertion
case_error_context = do
@@ -271,16 +285,13 @@ case_error_context = do
<*> option (long "key")
i = info p idm
result = run i ["--port", "foo", "--key", "291"]
- case result of
- Left (ParserFailure err _) -> do
- msg <- err "test"
+ assertError result $ \(ParserFailure err) -> do
+ let (msg, _) = err "test"
let errMsg = head $ lines msg
assertBool "no context in error message (option)"
("port" `isInfixOf` errMsg)
assertBool "no context in error message (value)"
("foo" `isInfixOf` errMsg)
- Right val ->
- assertFailure $ "unexpected result " ++ show val
where
pk :: Int -> Int -> (Int, Int)
pk = (,)
@@ -298,7 +309,7 @@ case_arg_order_1 = do
<*> argument (condr odd) idm
i = info p idm
result = run i ["3", "6"]
- assertLeft result $ \_ -> return ()
+ assertError result $ \_ -> return ()
case_arg_order_2 :: Assertion
case_arg_order_2 = do
@@ -309,8 +320,8 @@ case_arg_order_2 = do
i = info p idm
result = run i ["2", "-b", "3", "-a", "6"]
case result of
- Left _ -> assertFailure "unexpected parse error"
- Right res -> (2, 6, 3) @=? res
+ Success res -> (2, 6, 3) @=? res
+ _ -> assertFailure "unexpected parse error"
case_arg_order_3 :: Assertion
case_arg_order_3 = do
@@ -321,26 +332,35 @@ case_arg_order_3 = do
i = info p idm
result = run i ["-n", "3", "5"]
case result of
- Left _ ->
- assertFailure "unexpected parse error"
- Right res -> (3, 5) @=? res
+ Success res -> (3, 5) @=? res
+ _ -> assertFailure "unexpected parse error"
case_issue_47 :: Assertion
case_issue_47 = do
let p = nullOption (long "test" <> reader r <> value 9) :: Parser Int
r _ = readerError "error message"
result = run (info p idm) ["--test", "x"]
- assertLeft result $ \(ParserFailure err _) -> do
- text <- head . lines <$> err "test"
+ assertError result $ \(ParserFailure err) -> do
+ let text = head . lines . fst . err $ "test"
assertBool "no error message"
("error message" `isInfixOf` text)
+case_long_help :: Assertion
+case_long_help = do
+ let p = Formatting.opts <**> helper
+ i = info p
+ ( progDesc (concat
+ [ "This is a very long program description. "
+ , "This text should be automatically wrapped "
+ , "to fit the size of the terminal" ]) )
+ checkHelpTextWith (prefs (columns 50)) "formatting" i ["--help"]
+
case_issue_50 :: Assertion
case_issue_50 = do
let p = argument str (metavar "INPUT")
<* switch (long "version")
result = run (info p idm) ["--version", "test"]
- assertRight result $ \r -> "test" @=? r
+ assertResult result $ \r -> "test" @=? r
case_intersperse_1 :: Assertion
case_intersperse_1 = do
@@ -348,7 +368,7 @@ case_intersperse_1 = do
<* switch (short 'x')
result = run (info p noIntersperse)
["a", "-x", "b"]
- assertRight result $ \args -> ["a", "-x", "b"] @=? args
+ assertResult result $ \args -> ["a", "-x", "b"] @=? args
case_intersperse_2 :: Assertion
case_intersperse_2 = do
@@ -362,8 +382,8 @@ case_intersperse_2 = do
i = info p idm
result1 = run i ["run", "-x", "foo"]
result2 = run i ["test", "-x", "bar"]
- assertRight result1 $ \args -> ["-x", "foo"] @=? args
- assertLeft result2 $ \_ -> return ()
+ assertResult result1 $ \args -> ["-x", "foo"] @=? args
+ assertError result2 $ \_ -> return ()
case_issue_52 :: Assertion
case_issue_52 = do
@@ -371,9 +391,43 @@ case_issue_52 = do
( metavar "FOO"
<> command "run" (info (pure "foo") idm) )
i = info p idm
- assertLeft (run i []) $ \(ParserFailure err _) -> do
- text <- head . lines <$> err "test"
+ assertError (run i []) $ \(ParserFailure err) -> do
+ let text = head . lines . fst . err $ "test"
"Usage: test FOO" @=? text
+---
+
+deriving instance Arbitrary a => Arbitrary (Chunk a)
+deriving instance Eq SimpleDoc
+
+equalDocs :: Float -> Int -> Doc -> Doc -> Bool
+equalDocs f w d1 d2 = Doc.renderPretty f w d1
+ == Doc.renderPretty f w d2
+
+prop_listToChunk_1 :: [String] -> Bool
+prop_listToChunk_1 xs = isEmpty (listToChunk xs) == null xs
+
+prop_listToChunk_2 :: [String] -> Bool
+prop_listToChunk_2 xs = listToChunk xs == mconcat (fmap pure xs)
+
+prop_extractChunk_1 :: String -> Bool
+prop_extractChunk_1 x = extractChunk (pure x) == x
+
+prop_extractChunk_2 :: Chunk String -> Bool
+prop_extractChunk_2 x = extractChunk (fmap pure x) == x
+
+prop_stringChunk_1 :: Positive Float -> Positive Int -> String -> Bool
+prop_stringChunk_1 (Positive f) (Positive w) s =
+ equalDocs f w (extractChunk (stringChunk s))
+ (Doc.string s)
+
+prop_stringChunk_2 :: String -> Bool
+prop_stringChunk_2 s = isEmpty (stringChunk s) == null s
+
+prop_paragraph :: String -> Bool
+prop_paragraph s = isEmpty (paragraph s) == null (words s)
+
+---
+
main :: IO ()
main = $(defaultMainGenerator)
View
14 tests/formatting.err.txt
@@ -0,0 +1,14 @@
+Usage: formatting [-t|--test FOO_BAR_BAZ_LONG_METAVARIABLE]
+ This is a very long program description. This
+ text should be automatically wrapped to fit the
+ size of the terminal
+
+Available options:
+ -t,--test FOO_BAR_BAZ_LONG_METAVARIABLE
+ 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
Please sign in to comment.
Something went wrong with that request. Please try again.