diff --git a/Options/Applicative/BashCompletion.hs b/Options/Applicative/BashCompletion.hs --- a/Options/Applicative/BashCompletion.hs +++ b/Options/Applicative/BashCompletion.hs @@ -6,23 +6,21 @@ 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 :: Parser a -> ParserPrefs -> Parser ParserFailure -bashCompletionParser parser pprefs = complParser +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 <$> - ( bashCompletionQuery parser pprefs + ( bashCompletionQuery pinfo pprefs <$> (many . strOption) (long "bash-completion-word" `mappend` internal) <*> option (long "bash-completion-index" `mappend` internal) ) @@ -30,8 +28,8 @@ (bashCompletionScript <$> strOption (long "bash-completion-script" `mappend` internal)) ] -bashCompletionQuery :: Parser a -> ParserPrefs -> [String] -> Int -> String -> IO [String] -bashCompletionQuery parser pprefs ws i _ = case runCompletion compl pprefs of +bashCompletionQuery :: ParserInfo a -> ParserPrefs -> [String] -> Int -> String -> IO [String] +bashCompletionQuery pinfo pprefs ws i _ = case runCompletion compl pprefs of Just (Left (SomeParser p)) -> list_options p Just (Right c) -> run_completer c _ -> return [] @@ -42,30 +40,35 @@ . 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 _ -> const True compl = do - setParser Nothing parser - runParserFully parser (drop 1 ws') + setParser Nothing (infoParser pinfo) + runParserInfo pinfo (drop 1 ws') bashCompletionScript :: String -> String -> IO [String] bashCompletionScript prog progn = return diff --git a/Options/Applicative/Builder.hs b/Options/Applicative/Builder.hs --- a/Options/Applicative/Builder.hs +++ b/Options/Applicative/Builder.hs @@ -34,6 +34,7 @@ short, long, help, + helpDoc, value, showDefaultWith, showDefault, @@ -69,9 +70,13 @@ fullDesc, briefDesc, header, - progDesc, + headerDoc, footer, + footerDoc, + progDesc, + progDescDoc, failureCode, + noIntersperse, info, -- * Builder for 'ParserPrefs' @@ -80,7 +85,7 @@ disambiguate, showHelpOnError, noBacktrack, - noIntersperse, + columns, prefs, -- * Types @@ -103,6 +108,8 @@ 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 = 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,8 +151,13 @@ -- | 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 reader f = fieldMod $ \p -> p { optReader = f } @@ -159,7 +171,7 @@ 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. @@ -197,7 +209,7 @@ subparser :: Mod CommandFields a -> Parser a subparser m = mkParser d g rdr where - Mod _ d g = m `mappend` metavar "COMMAND" + Mod _ d g = metavar "COMMAND" `mappend` m rdr = uncurry CmdReader (mkCommand m) -- | Builder for an argument parser. @@ -209,10 +221,12 @@ -- | Builder for an argument list parser. All arguments are collected and -- returned as a list. +{-# DEPRECATED arguments "Use many and argument instead" #-} arguments :: (String -> Maybe a) -> Mod ArgumentFields a -> Parser [a] arguments r m = many (argument r m) -- | Like `arguments`, but require at least one argument. +{-# DEPRECATED arguments1 "Use some and argument instead" #-} arguments1 :: (String -> Maybe a) -> Mod ArgumentFields a -> Parser [a] arguments1 r m = some (argument r m) @@ -304,20 +318,39 @@ -- | 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 failureCode n = InfoMod $ \i -> i { infoFailureCode = n } +-- | Disable parsing of regular options after arguments +noIntersperse :: InfoMod a +noIntersperse = InfoMod $ \p -> p { infoIntersperse = False } + -- | Create a 'ParserInfo' given a 'Parser' and a modifier. info :: Parser a -> InfoMod a -> ParserInfo a info parser m = applyInfoMod m base @@ -325,10 +358,11 @@ base = ParserInfo { infoParser = parser , infoFullDesc = True - , infoProgDesc = "" - , infoHeader = "" - , infoFooter = "" - , infoFailureCode = 1 } + , infoProgDesc = mempty + , infoHeader = mempty + , infoFooter = mempty + , infoFailureCode = 1 + , infoIntersperse = True } newtype PrefsMod = PrefsMod { applyPrefsMod :: ParserPrefs -> ParserPrefs } @@ -349,8 +383,8 @@ noBacktrack :: PrefsMod noBacktrack = PrefsMod $ \p -> p { prefBacktrack = False } -noIntersperse :: PrefsMod -noIntersperse = PrefsMod $ \p -> p { prefIntersperse = False } +columns :: Int -> PrefsMod +columns cols = PrefsMod $ \p -> p { prefColumns = cols } prefs :: PrefsMod -> ParserPrefs prefs m = applyPrefsMod m base @@ -360,7 +394,7 @@ , prefDisambiguate = False , prefShowHelpOnError = False , prefBacktrack = True - , prefIntersperse = True } + , prefColumns = 80 } -- convenience shortcuts diff --git a/Options/Applicative/Builder/Internal.hs b/Options/Applicative/Builder/Internal.hs --- a/Options/Applicative/Builder/Internal.hs +++ b/Options/Applicative/Builder/Internal.hs @@ -3,6 +3,8 @@ Mod(..), HasName(..), HasCompleter(..), + HasValue, + HasMetavar, OptionFields(..), FlagFields(..), CommandFields(..), @@ -62,6 +64,23 @@ 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 { propMetaVar = "" , propVisibility = Visible - , propHelp = "" + , propHelp = mempty , propShowDefault = Nothing } mkCommand :: Mod CommandFields a -> ([String], String -> Maybe (ParserInfo a)) diff --git a/Options/Applicative/Common.hs b/Options/Applicative/Common.hs --- a/Options/Applicative/Common.hs +++ b/Options/Applicative/Common.hs @@ -32,11 +32,16 @@ -- -- A basic 'ParserInfo' with default values for fields can be created using -- the 'info' function. + -- + -- A 'ParserPrefs' contains general preferences for all command-line + -- options, and can be built with the 'prefs' function. ParserInfo(..), + ParserPrefs(..), -- * Running parsers - runParser, + runParserInfo, runParserFully, + runParser, evalParser, -- * Low-level utilities @@ -83,8 +88,6 @@ mappend m@(Match _) _ = m mappend _ m = m -type Args = [String] - argMatches :: MonadP m => OptReader a -> String -> Maybe (StateT Args m a) argMatches opt arg = case opt of @@ -96,12 +99,11 @@ setContext (Just arg) subp prefs <- getPrefs let runSubparser - | prefBacktrack prefs = \p a -> do - policy <- getPolicy - runParser policy p a - | otherwise = \p a - -> (,) <$> runParserFully p a <*> pure [] - runSubparser (infoParser subp) args + | prefBacktrack prefs = \i a -> do + runParser (getPolicy i) (infoParser i) a + | otherwise = \i a + -> (,) <$> runParserInfo i a <*> pure [] + runSubparser subp args _ -> Nothing optMatches :: MonadP m => Bool -> OptReader a -> OptWord -> Maybe (StateT Args m a) @@ -185,11 +187,6 @@ Just matcher -> lift matcher Nothing -> mzero -data ArgPolicy - = SkipOpts - | AllowOpts - deriving Eq - stepParser :: MonadP m => ParserPrefs -> ArgPolicy -> String -> Parser a -> NondetT (StateT Args m) (Parser a) stepParser pprefs SkipOpts arg p = case parseWord arg of @@ -226,16 +223,17 @@ ('-':_) -> "Invalid option `" ++ arg ++ "'" _ -> "Invalid argument `" ++ arg ++ "'" -getPolicy :: MonadP m => m ArgPolicy -getPolicy = do - prefs <- getPrefs - return $ if prefIntersperse prefs - then SkipOpts - else AllowOpts +getPolicy :: ParserInfo a -> ArgPolicy +getPolicy i = if infoIntersperse i + then SkipOpts + else AllowOpts -runParserFully :: MonadP m => Parser a -> Args -> m a -runParserFully p args = do - policy <- getPolicy +runParserInfo :: MonadP m => ParserInfo a -> Args -> m a +runParserInfo i args + = runParserFully (getPolicy i) (infoParser i) args + +runParserFully :: MonadP m => ArgPolicy -> Parser a -> Args -> m a +runParserFully policy p args = do (r, args') <- runParser policy p args guard $ null args' return r diff --git a/Options/Applicative/Extra.hs b/Options/Applicative/Extra.hs --- a/Options/Applicative/Extra.hs +++ b/Options/Applicative/Extra.hs @@ -10,15 +10,17 @@ 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.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 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 @@ -- -- 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 - parser = infoParser pinfo - parser' = (Extra <$> bashCompletionParser parser pprefs) - <|> (Result <$> parser) - p = runParserFully parser' args + pinfo' = 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 - = [] + ErrorMsg _ -> ExitFailure (infoFailureCode pinfo) + _ -> ExitSuccess with_context :: Context -> ParserInfo a @@ -156,9 +127,32 @@ 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) diff --git a/Options/Applicative/Help.hs b/Options/Applicative/Help.hs --- a/Options/Applicative/Help.hs +++ b/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 diff --git a/Options/Applicative/Help/Chunk.hs b/Options/Applicative/Help/Chunk.hs new file mode 100644 --- /dev/null +++ b/Options/Applicative/Help/Chunk.hs @@ -0,0 +1,136 @@ +{-# LANGUAGE CPP #-} +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 + +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 diff --git a/Options/Applicative/Help/Core.hs b/Options/Applicative/Help/Core.hs new file mode 100644 --- /dev/null +++ b/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)) ] diff --git a/Options/Applicative/Help/Pretty.hs b/Options/Applicative/Help/Pretty.hs new file mode 100644 --- /dev/null +++ b/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.<$>) diff --git a/Options/Applicative/Types.hs b/Options/Applicative/Types.hs --- a/Options/Applicative/Types.hs +++ b/Options/Applicative/Types.hs @@ -17,7 +17,11 @@ ParserM(..), Completer(..), mkCompleter, + CompletionResult(..), ParserFailure(..), + ParserResult(..), + Args, + ArgPolicy(..), OptHelpInfo(..), OptTree(..), @@ -39,6 +43,9 @@ 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,12 +57,15 @@ -- | 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 + { 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 @@ -70,8 +80,8 @@ -- (default: False) , prefBacktrack :: Bool -- ^ backtrack to parent parser when a -- subcommand fails (default: True) - , prefIntersperse :: Bool -- ^ allow regular options and flags to occur - -- after arguments (default: True) + , prefColumns :: Int -- ^ number of columns in the terminal, used to + -- format the help page (default: 80) } data OptName = OptShort !Char @@ -88,7 +98,7 @@ -- | 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 } @@ -221,18 +231,25 @@ 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 } -instance Error ParserFailure where - strMsg msg = ParserFailure - { errMessage = \_ -> return msg - , errExitCode = ExitFailure 1 } +newtype ParserFailure = ParserFailure + { execFailure :: String -> (String, ExitCode) } +-- | Result of 'execParserPure'. +data ParserResult a + = Success a + | Failure ParserFailure + | CompletionInvoked CompletionResult + +type Args = [String] + +data ArgPolicy + = SkipOpts + | AllowOpts + deriving Eq + data OptHelpInfo = OptHelpInfo { hinfoMulti :: Bool , hinfoDefault :: Bool } @@ -246,7 +263,7 @@ optVisibility :: Option a -> OptVisibility optVisibility = propVisibility . optProps -optHelp :: Option a -> String +optHelp :: Option a -> Chunk Doc optHelp = propHelp . optProps optMetaVar :: Option a -> String diff --git a/Options/Applicative/Utils.hs b/Options/Applicative/Utils.hs deleted file mode 100644 --- a/Options/Applicative/Utils.hs +++ /dev/null @@ -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 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -212,11 +212,17 @@ for which the reader succeeds. For example ```haskell -argument str ( metavar "FILE" ) +argument str (metavar "FILE") ``` -creates an argument accepting any string. +creates an argument accepting any string. To accept an arbitrary number of +arguments, combine the `argument` builder with either the `many` or `some` +combinator: +```haskell +some (argument str (metavar "FILES...")) +``` + Arguments are only displayed in the brief help text, so there's no need to attach a description to them. They should be manually documented in the program description. @@ -303,39 +309,13 @@ See the haddock documentation for `Options.Applicative.Builder` for a full list of builders and modifiers. -## Arrow interface - -It is also possible to use the [Arrow syntax][arrows] to combine basic parsers. - -This can be particularly useful when the structure holding parse results is -deeply nested, or when the order of fields differs from the order in which the -parsers should be applied. - -Using functions from the `Options.Applicative.Arrows` module, one can write, -for example: - -```haskell -data Options = Options - { optArgs :: [String] - , optVerbose :: Bool } - -opts :: Parser Options -opts = runA $ proc () -> do - verbosity <- asA (option (short 'v' <> value 0)) -< () - let verbose = verbosity > 0 - args <- asA (arguments str idm) -< () - returnA -< Options args verbose -``` - -where parsers are converted to arrows using `asA`, and the resulting composed -arrow is converted back to a `Parser` with `runA`. +## Advanced features -See `tests/Examples/Cabal.hs` for a slightly more elaborate example using the -arrow syntax for defining parsers. +* [Bash completion][bash] +* [Arrow interface][arrows] -Note that the `Arrow` interface is provided only for convenience. The API based -on `Applicative` is just as expressive, although it might be cumbersome to use -in certain cases. + [bash]: https://github.com/pcapriotti/optparse-applicative/wiki/Bash-Completion + [arrows]: https://github.com/pcapriotti/optparse-applicative/wiki/Arrows ## How it works diff --git a/optparse-applicative.cabal b/optparse-applicative.cabal --- a/optparse-applicative.cabal +++ b/optparse-applicative.cabal @@ -1,5 +1,5 @@ name: optparse-applicative -version: 0.7.0.2 +version: 0.8.0 synopsis: Utilities and combinators for parsing command line options description: Here is a simple example of an applicative option parser: @@ -96,21 +96,26 @@ Options.Applicative.Common, Options.Applicative.Extra, Options.Applicative.Help, + Options.Applicative.Help.Pretty, + Options.Applicative.Help.Chunk, + Options.Applicative.Help.Core, Options.Applicative.Types, - Options.Applicative.Utils - other-modules: Options.Applicative.Internal + 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.* diff --git a/tests/Examples/Cabal.hs b/tests/Examples/Cabal.hs --- a/tests/Examples/Cabal.hs +++ b/tests/Examples/Cabal.hs @@ -118,7 +118,8 @@ returnA -< BuildOpts bdir pinfo :: ParserInfo Args -pinfo = info parser idm +pinfo = info parser + ( progDesc "An example modelled on cabal" ) main :: IO () main = do diff --git a/tests/Examples/Commands.hs b/tests/Examples/Commands.hs --- a/tests/Examples/Commands.hs +++ b/tests/Examples/Commands.hs @@ -16,7 +16,7 @@ deriving Show hello :: Parser Sample -hello = Hello <$> arguments str (metavar "TARGET...") +hello = Hello <$> many (argument str (metavar "TARGET...")) sample :: Parser Sample sample = subparser diff --git a/tests/Tests.hs b/tests/Tests.hs --- a/tests/Tests.hs +++ b/tests/Tests.hs @@ -1,54 +1,71 @@ -{-# 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 (<>) :: Monoid a => a -> a -> a (<>) = 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 => ExitCode -> ParserPrefs -> String + -> ParserInfo a -> [String] -> Assertion +checkHelpTextWith ecode 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 - ExitFailure 1 @=? code + let (msg, code) = err name + expected @=? msg ++ "\n" + ecode @=? code +checkHelpText :: Show a => String -> ParserInfo a -> [String] -> Assertion +checkHelpText = checkHelpTextWith ExitSuccess (prefs idm) + case_hello :: Assertion case_hello = checkHelpText "hello" Hello.opts ["--help"] @@ -62,42 +79,41 @@ 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 @@ 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 @@ 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 @@ -145,17 +162,17 @@ p2 = subparser (command "b" (info p3 idm)) p1 = subparser (command "c" (info p2 idm)) i = info (p1 <**> helper) idm - checkHelpText "nested" i ["c", "b"] + checkHelpTextWith (ExitFailure 1) (prefs idm) "nested" i ["c", "b"] case_many_args :: Assertion case_many_args = do - let p = arguments str idm + let p = many (argument str idm) i = info p idm 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 @@ 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 @@ 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,24 +204,24 @@ 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 - let p = arguments str (metavar "ARGS...") + let p = many (argument str (metavar "ARGS...")) 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,32 +232,32 @@ 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 = arguments1 str idm + 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 - let p = arguments1 str idm + let p = some (argument str idm) 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 let p = switch (short 'x') - *> arguments str idm + *> 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 @@ <|> 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 @@ <*> 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 @@ <*> 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 @@ <*> 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 @@ 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,35 +332,102 @@ 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 ExitSuccess (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 - let p = arguments str (metavar "ARGS") + let p = many (argument str (metavar "ARGS")) <* switch (short 'x') - result = execParserPure (prefs noIntersperse) - (info p idm) - ["a", "-x", "b"] - assertRight result $ \args -> ["a", "-x", "b"] @=? args + result = run (info p noIntersperse) + ["a", "-x", "b"] + assertResult result $ \args -> ["a", "-x", "b"] @=? args + +case_intersperse_2 :: Assertion +case_intersperse_2 = do + let p = subparser + ( command "run" + ( info (many (argument str (metavar "OPTIONS"))) + noIntersperse ) + <> command "test" + ( info (many (argument str (metavar "ARGS"))) + idm ) ) + i = info p idm + result1 = run i ["run", "-x", "foo"] + result2 = run i ["test", "-x", "bar"] + assertResult result1 $ \args -> ["-x", "foo"] @=? args + assertError result2 $ \_ -> return () + +case_issue_52 :: Assertion +case_issue_52 = do + let p = subparser + ( metavar "FOO" + <> command "run" (info (pure "foo") idm) ) + i = info p idm + 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)