optparse-applicative 0.9.1.1 → 0.10.0
raw patch · 18 files changed
+193/−589 lines, 18 filesdep −HUnitdep −QuickCheckdep −optparse-applicativedep ~base
Dependencies removed: HUnit, QuickCheck, optparse-applicative, test-framework, test-framework-hunit, test-framework-quickcheck2, test-framework-th-prime
Dependency ranges changed: base
Files
- CHANGELOG.md +22/−0
- Options/Applicative.hs +2/−0
- Options/Applicative/BashCompletion.hs +2/−2
- Options/Applicative/Builder.hs +24/−44
- Options/Applicative/Builder/Internal.hs +0/−1
- Options/Applicative/Common.hs +3/−4
- Options/Applicative/Extra.hs +33/−13
- Options/Applicative/Help.hs +1/−0
- Options/Applicative/Help/Chunk.hs +1/−2
- Options/Applicative/Help/Core.hs +6/−22
- Options/Applicative/Help/Types.hs +36/−0
- Options/Applicative/Internal.hs +5/−6
- Options/Applicative/Types.hs +40/−11
- README.md +12/−14
- optparse-applicative.cabal +4/−16
- tests/Examples/Cabal.hs +1/−1
- tests/Examples/Formatting.hs +1/−1
- tests/Tests.hs +0/−452
CHANGELOG.md view
@@ -1,3 +1,25 @@+## Version 0.10.0 (1 Sep 2014)++- Parser execution and help text generation are now more modular, and allow for+ greater customisation.++- More consistent API for `option` and `argument` builders: now `option` takes+ a reader as argument, and `nullOption` is deprecated in favour of `option`.+ The `reader` modifier is gone. Quick migration guide:++ * `option` (without a `reader` modifier) => `option auto`+ * `nullOption` (without a `reader` modifier) => `option disabled`+ * `option`/`nullOption` (with a `reader r` modifier) => `option r`.++- Added convenience builder `strArgument`, equivalent to `argument str`.++- Removed functions deprecated from at least version 0.8.0.++- Switched test infrastructure to `tasty`.++- Fixed bugs+ * \#63 - Inconsistency between 'argument' and 'strOption' types+ ## Version 0.9.1.1 (31 Jul 2014) - Fixed bugs
Options/Applicative.hs view
@@ -34,3 +34,5 @@ import Options.Applicative.Builder import Options.Applicative.Builder.Completer import Options.Applicative.Extra++{-# ANN module "HLint: ignore Use import/export shortcut" #-}
Options/Applicative/BashCompletion.hs view
@@ -28,7 +28,7 @@ ( bashCompletionQuery pinfo pprefs <$> (many . strOption) (long "bash-completion-word" `mappend` internal)- <*> option (long "bash-completion-index" `mappend` internal) )+ <*> option auto (long "bash-completion-index" `mappend` internal) ) , failure <$> (bashCompletionScript <$> strOption (long "bash-completion-script" `mappend` internal)) ]@@ -42,7 +42,7 @@ list_options = fmap concat . sequence- . mapParser (\_ -> opt_completions)+ . mapParser (const opt_completions) opt_completions opt = case optMain opt of OptReader ns _ _ -> return $ show_names ns
Options/Applicative/Builder.hs view
@@ -18,17 +18,16 @@ -- -- creates a parser for an option called \"output\". subparser,+ strArgument, argument,- arguments,- arguments1, flag, flag', switch,- nullOption, abortOption, infoOption, strOption, option,+ nullOption, -- * Modifiers short,@@ -39,7 +38,6 @@ showDefaultWith, showDefault, metavar,- reader, eitherReader, noArgError, ParseError(..),@@ -50,7 +48,6 @@ action, completer, idm,- (&), #if __GLASGOW_HASKELL__ > 702 (<>), #endif@@ -97,7 +94,7 @@ CommandFields ) where -import Control.Applicative (pure, (<|>), many, some)+import Control.Applicative (pure, (<|>)) import Data.Monoid (Monoid (..) #if __GLASGOW_HASKELL__ > 702 , (<>)@@ -158,13 +155,9 @@ 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 }---- | Specify the 'Option' reader as a function in the 'Either' monad.-eitherReader :: (String -> Either String a) -> Mod OptionFields a-eitherReader f = reader (either readerError return . f)+-- | Convert a function in the 'Either' monad to a reader.+eitherReader :: (String -> Either String a) -> String -> ReadM a+eitherReader f = either readerError return . f -- | Specify the error to display when no argument is provided to this option. noArgError :: ParseError -> Mod OptionFields a@@ -222,16 +215,9 @@ ArgumentFields compl = f (ArgumentFields mempty) rdr = CReader compl p --- | 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)+-- | Builder for a 'String' argument.+strArgument :: Mod ArgumentFields String -> Parser String+strArgument = argument str -- | Builder for a flag parser. --@@ -268,25 +254,14 @@ switch :: Mod FlagFields Bool -> Parser Bool switch = flag False True --- | Builder for an option with a null reader. A non-trivial reader can be--- added using the 'reader' modifier.-nullOption :: Mod OptionFields a -> Parser a-nullOption m = mkParser d g rdr- where- Mod f d g = metavar "ARG" `mappend` m- fields = f (OptionFields [] mempty disabled (ErrorMsg ""))- crdr = CReader (optCompleter fields) (optReader fields)- rdr = OptReader (optNames fields) crdr (optNoArgError fields)- -- | An option that always fails. -- -- When this option is encountered, the option parser immediately aborts with -- the given parse error. If you simply want to output a message, use -- 'infoOption' instead. abortOption :: ParseError -> Mod OptionFields (a -> a) -> Parser (a -> a)-abortOption err m = nullOption . (`mappend` m) $ mconcat- [ reader (const (ReadM (Left err)))- , noArgError err+abortOption err m = option (const (ReadM (Left err))) . (`mappend` m) $ mconcat+ [ noArgError err , value id , metavar "" ] @@ -296,11 +271,21 @@ -- | Builder for an option taking a 'String' argument. strOption :: Mod OptionFields String -> Parser String-strOption m = nullOption $ reader str `mappend` m+strOption = option str +-- | Same as 'option'.+{-# DEPRECATED nullOption "Use 'option' instead" #-}+nullOption :: (String -> ReadM a) -> Mod OptionFields a -> Parser a+nullOption = option+ -- | Builder for an option using the 'auto' reader.-option :: Read a => Mod OptionFields a -> Parser a-option m = nullOption $ reader auto `mappend` m+option :: (String -> ReadM a) -> Mod OptionFields a -> Parser a+option r m = mkParser d g rdr+ where+ Mod f d g = metavar "ARG" `mappend` m+ fields = f (OptionFields [] mempty (ErrorMsg ""))+ crdr = CReader (optCompleter fields) r+ rdr = OptReader (optNames fields) crdr (optNoArgError fields) -- | Modifier for 'ParserInfo'. newtype InfoMod a = InfoMod@@ -403,8 +388,3 @@ -- | Trivial option modifier. idm :: Monoid m => m idm = mempty---- | Compose modifiers.-{-# DEPRECATED (&) "Use (<>) instead" #-}-(&) :: Monoid m => m -> m -> m-(&) = mappend
Options/Applicative/Builder/Internal.hs view
@@ -33,7 +33,6 @@ data OptionFields a = OptionFields { optNames :: [OptName] , optCompleter :: Completer- , optReader :: String -> ReadM a , optNoArgError :: ParseError } data FlagFields a = FlagFields
Options/Applicative/Common.hs view
@@ -99,7 +99,7 @@ setContext (Just arg) subp prefs <- getPrefs let runSubparser- | prefBacktrack prefs = \i a -> do+ | prefBacktrack prefs = \i a -> runParser (getPolicy i) (infoParser i) a | otherwise = \i a -> (,) <$> runParserInfo i a <*> pure []@@ -201,9 +201,9 @@ -- arguments. This function returns an error if any parsing error occurs, or -- if any options are missing and don't have a default value. runParser :: MonadP m => ArgPolicy -> Parser a -> Args -> m (a, Args)+runParser SkipOpts p ("--" : argt) = runParser AllowOpts p argt runParser policy p args = case args of [] -> exitP p result- ("--" : argt) -> runParser AllowOpts p argt (arg : argt) -> do prefs <- getPrefs (mp', args') <- do_step prefs arg argt@@ -229,8 +229,7 @@ else AllowOpts runParserInfo :: MonadP m => ParserInfo a -> Args -> m a-runParserInfo i args- = runParserFully (getPolicy i) (infoParser i) args+runParserInfo i = runParserFully (getPolicy i) (infoParser i) runParserFully :: MonadP m => ArgPolicy -> Parser a -> Args -> m a runParserFully policy p args = do
Options/Applicative/Extra.hs view
@@ -10,8 +10,12 @@ customExecParser, customExecParserMaybe, execParserPure,+ getParseResult, handleParseResult,+ parserFailure,+ renderFailure, ParserFailure(..),+ overFailure, ParserResult(..), ParserPrefs(..), CompletionResult(..),@@ -20,7 +24,7 @@ import Control.Applicative (pure, (<$>), (<|>), (<**>)) import Data.Monoid (mempty, mconcat) import System.Environment (getArgs, getProgName)-import System.Exit (exitWith, ExitCode(..))+import System.Exit (exitSuccess, exitWith, ExitCode(..)) import System.IO (hPutStrLn, stderr) import Options.Applicative.BashCompletion@@ -67,7 +71,7 @@ handleParseResult (Success a) = return a handleParseResult (Failure failure) = do progn <- getProgName- let (msg, exit) = execFailure failure progn+ let (msg, exit) = renderFailure failure progn case exit of ExitSuccess -> putStrLn msg _ -> hPutStrLn stderr msg@@ -76,8 +80,19 @@ progn <- getProgName msg <- execCompletion compl progn putStr msg- exitWith ExitSuccess+ exitSuccess +-- | Extract the actual result from a `ParserResult` value.+--+-- This function returns 'Nothing' in case of errors. Possible error messages+-- or completion actions are simply discarded.+--+-- If you want to display error messages and invoke completion actions+-- appropriately, use 'handleParseResult' instead.+getParseResult :: ParserResult a -> Maybe a+getParseResult (Success a) = Just a+getParseResult _ = Nothing+ -- | Run a program description in pure code. -- -- This function behaves like 'execParser', but can be called from pure code.@@ -85,16 +100,16 @@ -- simply returns 'Nothing'. -- -- If you need to keep track of error messages, use 'execParserPure' instead.+{-# DEPRECATED execParserMaybe "Use execParserPure together with getParseResult instead" #-} execParserMaybe :: ParserInfo a -> [String] -> Maybe a execParserMaybe = customExecParserMaybe (prefs idm) -- | Run a program description with custom preferences in pure code. -- -- See 'execParserMaybe' for details.+{-# DEPRECATED customExecParserMaybe "Use execParserPure together with getParseResult instead" #-} customExecParserMaybe :: ParserPrefs -> ParserInfo a -> [String] -> Maybe a-customExecParserMaybe pprefs pinfo args = case execParserPure pprefs pinfo args of- Success r -> Just r- _ -> Nothing+customExecParserMaybe pprefs pinfo args = getParseResult $ execParserPure pprefs pinfo args -- | The most general way to run a program description in pure code. execParserPure :: ParserPrefs -- ^ Global preferences for this parser@@ -112,15 +127,20 @@ <|> (Right <$> infoParser pinfo) } p = runParserInfo pinfo' args +-- | Generate a `ParserFailure` from a `ParseError` in a given `Context`.+--+-- This function can be used, for example, to show the help text for a parser:+--+-- @handleParseResult . Failure $ parserFailure pprefs pinfo ShowHelpText mempty@ parserFailure :: ParserPrefs -> ParserInfo a -> ParseError -> Context- -> ParserFailure+ -> ParserFailure ParserHelp 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)+ in (h, exit_code, prefColumns pprefs) where exit_code = case msg of ErrorMsg _ -> ExitFailure (infoFailureCode pinfo)@@ -134,11 +154,6 @@ with_context NullContext i f = f [] i with_context (Context n i) _ f = f n i - render_help :: ParserHelp -> String- render_help = (`displayS` "")- . renderPretty 1.0 (prefColumns pprefs)- . helpText- usage_help progn names i = case msg of InfoMsg _ -> mempty _ -> usageHelp $ vcatChunks@@ -164,3 +179,8 @@ show_full_help = case msg of ShowHelpText -> True _ -> prefShowHelpOnError pprefs++renderFailure :: ParserFailure ParserHelp -> String -> (String, ExitCode)+renderFailure failure progn =+ let (h, exit, cols) = execFailure failure progn+ in (renderHelp cols h, exit)
Options/Applicative/Help.hs view
@@ -4,4 +4,5 @@ import Options.Applicative.Help.Pretty as X import Options.Applicative.Help.Chunk as X+import Options.Applicative.Help.Types as X import Options.Applicative.Help.Core as X
Options/Applicative/Help/Chunk.hs view
@@ -121,8 +121,7 @@ -- -- > isEmpty . paragraph = null . words paragraph :: String -> Chunk Doc-paragraph = foldr (chunked (</>)) mempty- . map stringChunk+paragraph = foldr (chunked (</>) . stringChunk) mempty . words tabulate' :: Int -> [(Doc, Doc)] -> Chunk Doc
Options/Applicative/Help/Core.hs view
@@ -3,14 +3,13 @@ briefDesc, fullDesc, ParserHelp(..),- helpText, errorHelp, headerHelp, usageHelp, bodyHelp, footerHelp, parserHelp,- parserUsage,+ parserUsage ) where import Control.Monad (guard)@@ -81,7 +80,7 @@ , descSurround = True } fold_tree (Leaf x) = x- fold_tree (MultNode xs) = foldr (<</>>) mempty . map fold_tree $ xs+ fold_tree (MultNode xs) = foldr ((<</>>) . fold_tree) mempty xs fold_tree (AltNode xs) = alt_node . filter (not . isEmpty) . map fold_tree $ xs@@ -102,7 +101,7 @@ return (extractChunk n, align . extractChunk $ h <<+>> hdef) where n = optDesc pprefs style info opt- h = optHelp $ opt+ h = optHelp opt hdef = Chunk . fmap show_def . optShowDefault $ opt show_def s = parens (string "default:" <+> string s) style = OptDescStyle@@ -110,20 +109,6 @@ , descHidden = True , descSurround = False } -data ParserHelp = ParserHelp- { helpError :: Chunk Doc- , helpHeader :: Chunk Doc- , helpUsage :: Chunk Doc- , helpBody :: Chunk Doc- , helpFooter :: Chunk Doc }--instance Monoid ParserHelp where- mempty = ParserHelp mempty mempty mempty mempty mempty- mappend (ParserHelp e1 h1 u1 b1 f1) (ParserHelp e2 h2 u2 b2 f2)- = ParserHelp (mappend e1 e2) (mappend h1 h2)- (mappend u1 u2) (mappend b1 b2)- (mappend f1 f2)- errorHelp :: Chunk Doc -> ParserHelp errorHelp chunk = ParserHelp chunk mempty mempty mempty mempty @@ -139,9 +124,6 @@ footerHelp :: Chunk Doc -> ParserHelp footerHelp chunk = ParserHelp mempty mempty mempty mempty chunk -helpText :: ParserHelp -> Doc-helpText (ParserHelp e h u b f) = extractChunk . vsepChunks $ [e, h, u, b, f]- -- | Generate the help text for a program. parserHelp :: ParserPrefs -> Parser a -> ParserHelp parserHelp pprefs p = bodyHelp . vsepChunks $@@ -153,7 +135,9 @@ -- | Generate option summary. parserUsage :: ParserPrefs -> Parser a -> String -> Doc-parserUsage pprefs p progn = hsep $+parserUsage pprefs p progn = hsep [ string "Usage:" , string progn , align (extractChunk (briefDesc pprefs p)) ]++{-# ANN footerHelp "HLint: ignore Eta reduce" #-}
+ Options/Applicative/Help/Types.hs view
@@ -0,0 +1,36 @@+module Options.Applicative.Help.Types (+ ParserHelp(..),+ renderHelp+ ) where++import Data.Monoid++import Options.Applicative.Help.Chunk+import Options.Applicative.Help.Pretty++data ParserHelp = ParserHelp+ { helpError :: Chunk Doc+ , helpHeader :: Chunk Doc+ , helpUsage :: Chunk Doc+ , helpBody :: Chunk Doc+ , helpFooter :: Chunk Doc }++instance Show ParserHelp where+ showsPrec _ h = showString (renderHelp 80 h)++instance Monoid ParserHelp where+ mempty = ParserHelp mempty mempty mempty mempty mempty+ mappend (ParserHelp e1 h1 u1 b1 f1) (ParserHelp e2 h2 u2 b2 f2)+ = ParserHelp (mappend e1 e2) (mappend h1 h2)+ (mappend u1 u2) (mappend b1 b2)+ (mappend f1 f2)++helpText :: ParserHelp -> Doc+helpText (ParserHelp e h u b f) = extractChunk . vsepChunks $ [e, h, u, b, f]++-- | Convert a help text to 'String'.+renderHelp :: Int -> ParserHelp -> String+renderHelp cols+ = (`displayS` "")+ . renderPretty 1.0 cols+ . helpText
Options/Applicative/Internal.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE GADTs, RankNTypes #-}+{-# LANGUAGE ExistentialQuantification #-} module Options.Applicative.Internal ( P , Context(..)@@ -72,9 +72,9 @@ mplus (P x) (P y) = P $ mplus x y -data Context where- Context :: [String] -> ParserInfo a -> Context- NullContext :: Context+data Context+ = forall a . Context [String] (ParserInfo a)+ | NullContext contextNames :: Context -> [String] contextNames (Context ns _) = ns@@ -108,8 +108,7 @@ uncons [] = Nothing uncons (x : xs) = Just (x, xs) -data SomeParser where- SomeParser :: Parser a -> SomeParser+data SomeParser = forall a . SomeParser (Parser a) data ComplError = ComplParseError String
Options/Applicative/Types.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE GADTs, Rank2Types #-}+{-# LANGUAGE Rank2Types, ExistentialQuantification #-} module Options.Applicative.Types ( ParseError(..), ParserInfo(..),@@ -20,10 +20,12 @@ CompletionResult(..), ParserFailure(..), ParserResult(..),+ overFailure, Args, ArgPolicy(..), OptHelpInfo(..), OptTree(..),+ ParserHelp(..), fromM, oneM,@@ -42,6 +44,7 @@ import Data.Monoid (Monoid(..)) import System.Exit (ExitCode(..)) +import Options.Applicative.Help.Types import Options.Applicative.Help.Pretty import Options.Applicative.Help.Chunk @@ -168,12 +171,12 @@ fmap f (CmdReader cs g) = CmdReader cs ((fmap . fmap) f . g) -- | A @Parser a@ is an option parser returning a value of type 'a'.-data Parser a where- NilP :: Maybe a -> Parser a- OptP :: Option a -> Parser a- MultP :: Parser (a -> b) -> Parser a -> Parser b- AltP :: Parser a -> Parser a -> Parser a- BindP :: Parser a -> (a -> Parser b) -> Parser b+data Parser a+ = NilP (Maybe a)+ | OptP (Option a)+ | forall x . MultP (Parser (x -> a)) (Parser x)+ | AltP (Parser a) (Parser a)+ | forall x . BindP (Parser x) (x -> Parser a) instance Functor Parser where fmap f (NilP x) = NilP (fmap f x)@@ -240,21 +243,47 @@ showsPrec p _ = showParen (p > 10) $ showString "CompletionResult _" -newtype ParserFailure = ParserFailure- { execFailure :: String -> (String, ExitCode) }+newtype ParserFailure h = ParserFailure+ { execFailure :: String -> (h, ExitCode, Int) } -instance Show ParserFailure where+instance Show h => Show (ParserFailure h) where showsPrec p (ParserFailure f) = showParen (p > 10) $ showString "ParserFailure " . showsPrec 11 (f "<program>") +instance Functor ParserFailure where+ fmap f (ParserFailure err) = ParserFailure $ \progn ->+ let (h, exit, cols) = err progn in (f h, exit, cols)+ -- | Result of 'execParserPure'. data ParserResult a = Success a- | Failure ParserFailure+ | Failure (ParserFailure ParserHelp) | CompletionInvoked CompletionResult deriving Show++instance Functor ParserResult where+ fmap f (Success a) = Success (f a)+ fmap _ (Failure f) = Failure f+ fmap _ (CompletionInvoked c) = CompletionInvoked c++overFailure :: (ParserHelp -> ParserHelp)+ -> ParserResult a -> ParserResult a+overFailure f (Failure failure) = Failure $ fmap f failure+overFailure _ r = r++instance Applicative ParserResult where+ pure = Success+ Success f <*> r = fmap f r+ Failure f <*> _ = Failure f+ CompletionInvoked c <*> _ = CompletionInvoked c++instance Monad ParserResult where+ return = pure+ Success x >>= f = f x+ Failure f >>= _ = Failure f+ CompletionInvoked c >>= _ = CompletionInvoked c type Args = [String]
README.md view
@@ -83,8 +83,8 @@ ```haskell optional $ strOption- ( long "output"- & metavar "DIRECTORY" )+ ( long "output"+ <> metavar "DIRECTORY" ) ``` [applicative]: http://www.soi.city.ac.uk/~ross/papers/Applicative.html@@ -141,14 +141,14 @@ `FILE` in the help text and documentation), a long name "output" and a short name "o". See below for more information on the builder syntax and modifiers. -A regular option can return an object of any type, provided you specify a-**reader** for it. A common reader is `auto`, used by the `option` builder,-which assumes a `Read` instance for the return type and uses it to parse its-argument. For example:+A regular option can return an object of any type, and takes a *reader*+parameter which specifies how the argument should be parsed. A common reader is+`auto`, which assumes a `Read` instance for the return type and uses it to parse+its argument. For example: ```haskell lineCount :: Parser Int-lineCount = option+lineCount = option auto ( long "lines" <> short 'n' <> metavar "K"@@ -161,18 +161,16 @@ the type will be normally inferred from the context in which the parser is used. -You can also create a custom reader without using the `Read` typeclass, and set-it as the reader for an option using the `reader` modifier and the `nullOption`-builder:+You can also create a custom reader that doesn't use the `Read` typeclass, and+use it to parse option arguments: ```haskell data FluxCapacitor = ... parseFluxCapacitor :: Monad m => String -> m FluxCapacitor -nullOption- ( long "flux-capacitor"- <> reader parseFluxCapacitor )+option parseFluxCapacitor+ ( long "flux-capacitor" ) ``` ### Flags@@ -190,7 +188,7 @@ flag Normal Verbose ( long "verbose" <> short 'v'- <> help "Enable verbose mode"+ <> help "Enable verbose mode" ) ``` is a flag parser returning a `Verbosity` value.
optparse-applicative.cabal view
@@ -1,5 +1,5 @@ name: optparse-applicative-version: 0.9.1.1+version: 0.10.0 synopsis: Utilities and combinators for parsing command line options description: Here is a simple example of an applicative option parser:@@ -64,8 +64,8 @@ license: BSD3 license-file: LICENSE author: Paolo Capriotti-maintainer: p.capriotti@gmail.com-copyright: (c) 2012 Paolo Capriotti <p.capriotti@gmail.com>+maintainer: paolo@capriotti.io+copyright: (c) 2012-2014 Paolo Capriotti <paolo@capriotti.io> category: System build-type: Simple cabal-version: >= 1.8@@ -105,6 +105,7 @@ Options.Applicative.Help.Pretty, Options.Applicative.Help.Chunk, Options.Applicative.Help.Core,+ Options.Applicative.Help.Types, Options.Applicative.Types, Options.Applicative.Internal ghc-options: -Wall@@ -113,16 +114,3 @@ transformers-compat == 0.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 -fno-warn-orphans- build-depends: base == 4.*,- HUnit == 1.2.*,- optparse-applicative,- QuickCheck >= 2.6 && < 2.8,- test-framework >= 0.6 && < 0.9,- test-framework-hunit >= 0.2 && < 0.4,- test-framework-quickcheck2 == 0.3.*,- test-framework-th-prime == 0.0.*
tests/Examples/Cabal.hs view
@@ -63,7 +63,7 @@ commonOpts :: Parser CommonOpts commonOpts = CommonOpts- <$> option+ <$> option auto ( short 'v' <> long "verbose" <> metavar "LEVEL"
tests/Examples/Formatting.hs view
@@ -4,7 +4,7 @@ import Options.Applicative opts :: Parser Int-opts = option $ mconcat+opts = option auto $ mconcat [ long "test" , short 't' , value 0
− tests/Tests.hs
@@ -1,452 +0,0 @@-{-# 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 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] -> ParserResult a-run = execParserPure (prefs idm)--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"--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"--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"- 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"]--case_modes :: Assertion-case_modes = checkHelpText "commands" Commands.opts ["--help"]--case_cmd_header :: Assertion-case_cmd_header = do- let i = info (helper <*> Commands.sample) (header "foo")- checkHelpTextWith (ExitFailure 1) (prefs idm)- "commands_header" i ["-zzz"]- checkHelpTextWith (ExitFailure 1) (prefs showHelpOnError)- "commands_header_full" i ["-zzz"]--case_cabal_conf :: Assertion-case_cabal_conf = checkHelpText "cabal" Cabal.pinfo ["configure", "--help"]--case_args :: Assertion-case_args = do- let result = run Commands.opts ["hello", "foo", "bar"]- case result of- Success (Commands.Hello args) ->- ["foo", "bar"] @=? args- 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- Success (Commands.Hello xs) ->- assertFailure $ "unexpected result: Hello " ++ show xs- 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- Success (Commands.Hello args) ->- ["foo", "--bar", "baz"] @=? args- 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- 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- let p = option ( short 'n'- <> help "set count"- <> value (0 :: Int)- <> showDefault)- i = info (p <**> helper) idm- result = run i ["--help"]- case result of- Failure (ParserFailure err) -> do- let (msg, _) = err "test"- assertHasLine- " -n ARG set count (default: 0)"- msg- Success r -> assertFailure $ "unexpected result: " ++ show r- CompletionInvoked _ -> assertFailure "unexpected completion"--case_alt_cont :: Assertion-case_alt_cont = do- let p = Alternatives.a <|> Alternatives.b- i = info p idm- result = run i ["-a", "-b"]- case result of- Success r -> assertFailure $ "unexpected result: " ++ show r- _ -> return ()--case_alt_help :: Assertion-case_alt_help = do- let p = p1 <|> p2 <|> p3- p1 = (Just . Left)- <$> strOption ( long "virtual-machine"- <> metavar "VM"- <> help "Virtual machine name" )- p2 = (Just . Right)- <$> strOption ( long "cloud-service"- <> metavar "CS"- <> help "Cloud service name" )- p3 = flag' Nothing ( long "dry-run" )- i = info (p <**> helper) idm- checkHelpText "alt" i ["--help"]--case_nested_commands :: Assertion-case_nested_commands = do- let p3 = strOption (short 'a' <> metavar "A")- p2 = subparser (command "b" (info p3 idm))- p1 = subparser (command "c" (info p2 idm))- i = info (p1 <**> helper) idm- checkHelpTextWith (ExitFailure 1) (prefs idm) "nested" i ["c", "b"]--case_many_args :: Assertion-case_many_args = do- let p = many (argument str idm)- i = info p idm- nargs = 20000- result = run i (replicate nargs "foo")- case result of- Success xs -> nargs @=? length xs- _ -> assertFailure "unexpected parse error"--case_disambiguate :: Assertion-case_disambiguate = do- let p = flag' (1 :: Int) (long "foo")- <|> flag' 2 (long "bar")- <|> flag' 3 (long "baz")- i = info p idm- result = execParserPure (prefs disambiguate) i ["--f"]- case result of- Success val -> 1 @=? val- _ -> assertFailure "unexpected parse error"--case_ambiguous :: Assertion-case_ambiguous = do- let p = flag' (1 :: Int) (long "foo")- <|> flag' 2 (long "bar")- <|> flag' 3 (long "baz")- i = info p idm- result = execParserPure (prefs disambiguate) i ["--ba"]- case result of- Success val -> assertFailure $ "unexpected result " ++ show val- _ -> return ()--case_completion :: Assertion-case_completion = do- let p = (,)- <$> strOption (long "foo"<> value "")- <*> strOption (long "bar"<> value "")- i = info p idm- result = run i ["--bash-completion-index", "0"]- case result of- CompletionInvoked (CompletionResult err) -> do- completions <- lines <$> err "test"- ["--foo", "--bar"] @=? completions- Failure _ -> assertFailure "unexpected failure"- Success val -> assertFailure $ "unexpected result " ++ show val--case_bind_usage :: Assertion-case_bind_usage = do- let p = many (argument str (metavar "ARGS..."))- i = info (p <**> helper) briefDesc- result = run i ["--help"]- case result of- Failure (ParserFailure err) -> do- let text = head . lines . fst $ err "test"- "Usage: test [ARGS...]" @=? text- Success val ->- assertFailure $ "unexpected result " ++ show val- CompletionInvoked _ -> assertFailure "unexpected completion"--case_issue_19 :: Assertion-case_issue_19 = do- let p = option- ( short 'x'- <> reader (fmap Just . str)- <> value Nothing )- i = info (p <**> helper) idm- result = run i ["-x", "foo"]- case result of- 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 []- assertError result $ \(ParserFailure _) -> return ()--case_arguments1_some :: Assertion-case_arguments1_some = do- let p = some (argument str idm)- i = info (p <**> helper) idm- result = run i ["foo", "--", "bar", "baz"]- case result of- Success r -> ["foo", "bar", "baz"] @=? r- _ -> assertFailure "unexpected parse error"--case_arguments_switch :: Assertion-case_arguments_switch = do- let p = switch (short 'x')- *> many (argument str idm)- i = info p idm- result = run i ["--", "-x"]- assertResult result $ \args -> ["-x"] @=? args--case_issue_35 :: Assertion-case_issue_35 = do- let p = flag' True (short 't' <> hidden)- <|> flag' False (short 'f')- i = info p idm- result = run i []- assertError result $ \(ParserFailure err) -> do- let text = head . lines . fst . err $ "test"- "Usage: test -f" @=? text--case_backtracking :: Assertion-case_backtracking = do- let p2 = switch (short 'a')- p1 = (,)- <$> subparser (command "c" (info p2 idm))- <*> switch (short 'b')- i = info (p1 <**> helper) idm- result = execParserPure (prefs noBacktrack) i ["c", "-b"]- assertError result $ \ _ -> return ()--case_error_context :: Assertion-case_error_context = do- let p = pk <$> option (long "port")- <*> option (long "key")- i = info p idm- result = run i ["--port", "foo", "--key", "291"]- 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)- where- pk :: Int -> Int -> (Int, Int)- pk = (,)--condr :: MonadPlus m => (Int -> Bool) -> String -> m Int-condr f arg = do- x <- auto arg- guard (f (x :: Int))- return x--case_arg_order_1 :: Assertion-case_arg_order_1 = do- let p = (,)- <$> argument (condr even) idm- <*> argument (condr odd) idm- i = info p idm- result = run i ["3", "6"]- assertError result $ \_ -> return ()--case_arg_order_2 :: Assertion-case_arg_order_2 = do- let p = (,,)- <$> argument (condr even) idm- <*> option (reader (condr even) <> short 'a')- <*> option (reader (condr odd) <> short 'b')- i = info p idm- result = run i ["2", "-b", "3", "-a", "6"]- case result of- Success res -> (2, 6, 3) @=? res- _ -> assertFailure "unexpected parse error"--case_arg_order_3 :: Assertion-case_arg_order_3 = do- let p = (,)- <$> ( argument (condr even) idm- <|> option (short 'n') )- <*> argument (condr odd) idm- i = info p idm- result = run i ["-n", "3", "5"]- case result of- 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"]- 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"]- assertResult result $ \r -> "test" @=? r--case_intersperse_1 :: Assertion-case_intersperse_1 = do- let p = many (argument str (metavar "ARGS"))- <* switch (short 'x')- 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--case_multiple_subparsers :: Assertion-case_multiple_subparsers = do- let p1 = subparser- (command "add" (info (pure ())- ( progDesc "Add a file to the repository" )))- p2 = subparser- (command "commit" (info (pure ())- ( progDesc "Record changes to the repository" )))- i = info (p1 *> p2 <**> helper) idm- checkHelpText "subparsers" i ["--help"]-------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)