mirror of
https://github.com/ilyakooo0/optparse-applicative.git
synced 2024-09-11 10:45:25 +03:00
847 lines
30 KiB
Haskell
847 lines
30 KiB
Haskell
{-# LANGUAGE StandaloneDeriving #-}
|
||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||
{-# LANGUAGE TemplateHaskell #-}
|
||
{-# 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.Applicative
|
||
import Control.Monad
|
||
import Data.ByteString (ByteString)
|
||
import qualified Data.ByteString.Char8 as BS8
|
||
import Data.List hiding (group)
|
||
import Data.Semigroup hiding (option)
|
||
import Data.String
|
||
|
||
import System.Exit
|
||
import Test.QuickCheck hiding (Success, Failure)
|
||
import Test.QuickCheck.Property
|
||
|
||
import Options.Applicative
|
||
import Options.Applicative.Types
|
||
import Options.Applicative.Help.Pretty (Doc, SimpleDoc(..))
|
||
import qualified Options.Applicative.Help.Pretty as Doc
|
||
import Options.Applicative.Help.Chunk
|
||
import Options.Applicative.Help.Levenshtein
|
||
|
||
import Prelude
|
||
|
||
run :: ParserInfo a -> [String] -> ParserResult a
|
||
run = execParserPure defaultPrefs
|
||
|
||
assertError :: Show a => ParserResult a
|
||
-> (ParserFailure ParserHelp -> Property) -> Property
|
||
assertError x f = case x of
|
||
Success r -> counterexample ("expected failure, got success: " ++ show r) failed
|
||
Failure e -> f e
|
||
CompletionInvoked _ -> counterexample "expected failure, got completion" failed
|
||
|
||
assertResult :: ParserResult a -> (a -> Property) -> Property
|
||
assertResult x f = case x of
|
||
Success r -> f r
|
||
Failure e -> do
|
||
let (msg, _) = renderFailure e "test"
|
||
counterexample ("unexpected parse error\n" ++ msg) failed
|
||
CompletionInvoked _ -> counterexample "expected result, got completion" failed
|
||
|
||
assertHasLine :: String -> String -> Property
|
||
assertHasLine l s = counterexample ("expected line:\n\t" ++ l ++ "\nnot found")
|
||
$ l `elem` lines s
|
||
|
||
checkHelpTextWith :: Show a => ExitCode -> ParserPrefs -> String
|
||
-> ParserInfo a -> [String] -> Property
|
||
checkHelpTextWith ecode pprefs name p args = ioProperty $ do
|
||
let result = execParserPure pprefs p args
|
||
expected <- readFile $ "tests/" ++ name ++ ".err.txt"
|
||
return $ assertError result $ \failure ->
|
||
let (msg, code) = renderFailure failure name
|
||
in (expected === msg ++ "\n") .&&. (ecode === code)
|
||
|
||
checkHelpText :: Show a => String -> ParserInfo a -> [String] -> Property
|
||
checkHelpText = checkHelpTextWith ExitSuccess defaultPrefs
|
||
|
||
prop_hello :: Property
|
||
prop_hello = once $
|
||
checkHelpText "hello" Hello.opts ["--help"]
|
||
|
||
prop_modes :: Property
|
||
prop_modes = once $
|
||
checkHelpText "commands" Commands.opts ["--help"]
|
||
|
||
prop_cmd_header :: Property
|
||
prop_cmd_header = once $
|
||
let i = info (helper <*> Commands.sample) (header "foo")
|
||
r1 = checkHelpTextWith (ExitFailure 1) defaultPrefs
|
||
"commands_header" i ["-zello"]
|
||
r2 = checkHelpTextWith (ExitFailure 1) (prefs showHelpOnError)
|
||
"commands_header_full" i ["-zello"]
|
||
in (r1 .&&. r2)
|
||
|
||
prop_cabal_conf :: Property
|
||
prop_cabal_conf = once $
|
||
checkHelpText "cabal" Cabal.pinfo ["configure", "--help"]
|
||
|
||
prop_args :: Property
|
||
prop_args = once $
|
||
let result = run Commands.opts ["hello", "foo", "bar"]
|
||
in assertResult result ((===) (Commands.Hello ["foo", "bar"]))
|
||
|
||
prop_args_opts :: Property
|
||
prop_args_opts = once $
|
||
let result = run Commands.opts ["hello", "foo", "--bar"]
|
||
in assertError result (\_ -> property succeeded)
|
||
|
||
prop_args_ddash :: Property
|
||
prop_args_ddash = once $
|
||
let result = run Commands.opts ["hello", "foo", "--", "--bar", "--", "baz"]
|
||
in assertResult result ((===) (Commands.Hello ["foo", "--bar", "--", "baz"]))
|
||
|
||
prop_alts :: Property
|
||
prop_alts = once $
|
||
let result = run Alternatives.opts ["-b", "-a", "-b", "-a", "-a", "-b"]
|
||
in assertResult result $ \xs ->
|
||
let a = Alternatives.A
|
||
b = Alternatives.B
|
||
in [b, a, b, a, a, b] === xs
|
||
|
||
prop_show_default :: Property
|
||
prop_show_default = once $
|
||
let p = option auto
|
||
( short 'n'
|
||
<> help "set count"
|
||
<> value (0 :: Int)
|
||
<> showDefault )
|
||
i = info (p <**> helper) idm
|
||
result = run i ["--help"]
|
||
in assertError result $ \failure ->
|
||
let (msg, _) = renderFailure failure "test"
|
||
in assertHasLine
|
||
" -n ARG set count (default: 0)"
|
||
msg
|
||
|
||
prop_alt_cont :: Property
|
||
prop_alt_cont = once $
|
||
let p = Alternatives.a <|> Alternatives.b
|
||
i = info p idm
|
||
result = run i ["-a", "-b"]
|
||
in assertError result (\_ -> property succeeded)
|
||
|
||
prop_alt_help :: Property
|
||
prop_alt_help = once $
|
||
let p :: Parser (Maybe (Either String String))
|
||
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
|
||
in checkHelpText "alt" i ["--help"]
|
||
|
||
prop_optional_help :: Property
|
||
prop_optional_help = once $
|
||
let p :: Parser (Maybe (String, String))
|
||
p = optional ((,)
|
||
<$> strOption ( long "a"
|
||
<> metavar "A"
|
||
<> help "value a" )
|
||
<*> strOption ( long "b"
|
||
<> metavar "B"
|
||
<> help "value b" ) )
|
||
i = info (p <**> helper) idm
|
||
in checkHelpText "optional" i ["--help"]
|
||
|
||
prop_optional_requiring_parens :: Property
|
||
prop_optional_requiring_parens = once $
|
||
let p = optional $
|
||
(,)
|
||
<$> flag' () ( short 'a' <> long "a" )
|
||
<*> flag' () ( short 'b' <> long "b" )
|
||
i = info (p <**> helper) briefDesc
|
||
result = run i ["--help"]
|
||
in assertError result $ \failure ->
|
||
let text = head . lines . fst $ renderFailure failure "test"
|
||
in "Usage: test [(-a|--a) (-b|--b)]" === text
|
||
|
||
prop_optional_alt_requiring_parens :: Property
|
||
prop_optional_alt_requiring_parens = once $
|
||
let p = optional $
|
||
flag' () ( short 'a' <> long "a" )
|
||
<|> flag' () ( short 'b' <> long "b" )
|
||
i = info (p <**> helper) briefDesc
|
||
result = run i ["--help"]
|
||
in assertError result $ \failure ->
|
||
let text = head . lines . fst $ renderFailure failure "test"
|
||
in "Usage: test [(-a|--a) | (-b|--b)]" === text
|
||
|
||
prop_nested_optional_help :: Property
|
||
prop_nested_optional_help = once $
|
||
let p :: Parser (String, Maybe (String, Maybe String))
|
||
p = (,) <$>
|
||
(strOption ( short 'a'
|
||
<> long "a"
|
||
<> metavar "A"
|
||
<> help "value a" ) ) <*>
|
||
(optional
|
||
((,) <$>
|
||
(strOption ( long "b0"
|
||
<> metavar "B0"
|
||
<> help "value b0" ) ) <*>
|
||
(optional (strOption ( long "b1"
|
||
<> metavar "B1"
|
||
<> help "value b1" )))))
|
||
i = info (p <**> helper) idm
|
||
in checkHelpText "nested_optional" i ["--help"]
|
||
|
||
prop_long_equals :: Property
|
||
prop_long_equals = once $
|
||
let p :: Parser String
|
||
p = option auto ( long "intval"
|
||
<> short 'j'
|
||
<> long "intval2"
|
||
<> short 'i'
|
||
<> help "integer value")
|
||
i = info (p <**> helper) fullDesc
|
||
in checkHelpTextWith ExitSuccess (prefs helpLongEquals) "long_equals" i ["--help"]
|
||
|
||
prop_long_equals_doesnt_do_shorts :: Property
|
||
prop_long_equals_doesnt_do_shorts = once $
|
||
let p :: Parser String
|
||
p = option auto ( short 'i'
|
||
<> help "integer value")
|
||
i = info (p <**> helper) fullDesc
|
||
result = execParserPure (prefs helpLongEquals) i ["--help"]
|
||
in assertError result $ \failure ->
|
||
let text = head . lines . fst $ renderFailure failure "test"
|
||
in "Usage: test -i ARG" === text
|
||
|
||
prop_nested_fun :: Property
|
||
prop_nested_fun = once $
|
||
let p :: Parser (String, Maybe (String, Maybe String))
|
||
p = (,) <$>
|
||
(strOption (short 'a' <> long "a" <> metavar "A")) <*>
|
||
(optional
|
||
((,) <$>
|
||
(strOption (short 'b' <> long "b" <> metavar "B")) <*>
|
||
(optional (strOption (short 'c' <> long "c" <> metavar "C")))))
|
||
i = info (p <**> helper) briefDesc
|
||
result = run i ["--help"]
|
||
in assertError result $ \failure ->
|
||
let text = head . lines . fst $ renderFailure failure "test"
|
||
in "Usage: test (-a|--a A) [(-b|--b B) [-c|--c C]]" === text
|
||
|
||
prop_nested_commands :: Property
|
||
prop_nested_commands = once $
|
||
let p3 :: Parser String
|
||
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
|
||
in checkHelpTextWith (ExitFailure 1) defaultPrefs "nested" i ["c", "b"]
|
||
|
||
prop_drops_back_contexts :: Property
|
||
prop_drops_back_contexts = once $
|
||
let p3 :: Parser String
|
||
p3 = strOption (short 'a' <> metavar "A")
|
||
p2 = subparser (command "b" (info p3 idm) <> metavar "B")
|
||
p1 = subparser (command "c" (info p3 idm) <> metavar "C")
|
||
p0 = (,) <$> p2 <*> p1
|
||
i = info (p0 <**> helper) idm
|
||
in checkHelpTextWith (ExitFailure 1) defaultPrefs "dropback" i ["b", "-aA"]
|
||
|
||
prop_context_carry :: Property
|
||
prop_context_carry = once $
|
||
let p3 :: Parser String
|
||
p3 = strOption (short 'a' <> metavar "A")
|
||
p2 = subparser (command "b" (info p3 idm) <> metavar "B")
|
||
p1 = subparser (command "c" (info p3 idm) <> metavar "C")
|
||
p0 = (,) <$> p2 <*> p1
|
||
i = info (p0 <**> helper) idm
|
||
in checkHelpTextWith (ExitFailure 1) defaultPrefs "carry" i ["b", "-aA", "c"]
|
||
|
||
prop_help_on_empty :: Property
|
||
prop_help_on_empty = once $
|
||
let p3 :: Parser String
|
||
p3 = strOption (short 'a' <> metavar "A")
|
||
p2 = subparser (command "b" (info p3 idm) <> metavar "B")
|
||
p1 = subparser (command "c" (info p3 idm) <> metavar "C")
|
||
p0 = (,) <$> p2 <*> p1
|
||
i = info (p0 <**> helper) idm
|
||
in checkHelpTextWith (ExitFailure 1) (prefs showHelpOnEmpty) "helponempty" i []
|
||
|
||
prop_help_on_empty_sub :: Property
|
||
prop_help_on_empty_sub = once $
|
||
let p3 :: Parser String
|
||
p3 = strOption (short 'a' <> metavar "A" <> help "both commands require this")
|
||
p2 = subparser (command "b" (info p3 idm) <> metavar "B")
|
||
p1 = subparser (command "c" (info p3 idm) <> metavar "C")
|
||
p0 = (,) <$> p2 <*> p1
|
||
i = info (p0 <**> helper) idm
|
||
in checkHelpTextWith (ExitFailure 1) (prefs showHelpOnEmpty) "helponemptysub" i ["b", "-aA", "c"]
|
||
|
||
prop_many_args :: Property
|
||
prop_many_args = forAll (choose (0,2000)) $ \nargs ->
|
||
let p :: Parser [String]
|
||
p = many (argument str idm)
|
||
i = info p idm
|
||
result = run i (replicate nargs "foo")
|
||
in assertResult result (\xs -> nargs === length xs)
|
||
|
||
prop_disambiguate :: Property
|
||
prop_disambiguate = once $
|
||
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"]
|
||
in assertResult result ((===) 1)
|
||
|
||
prop_ambiguous :: Property
|
||
prop_ambiguous = once $
|
||
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"]
|
||
in assertError result (\_ -> property succeeded)
|
||
|
||
prop_completion :: Property
|
||
prop_completion = once . ioProperty $
|
||
let p = (,)
|
||
<$> strOption (long "foo" <> value "")
|
||
<*> strOption (long "bar" <> value "")
|
||
i = info p idm
|
||
result = run i ["--bash-completion-index", "0"]
|
||
in case result of
|
||
CompletionInvoked (CompletionResult err) -> do
|
||
completions <- lines <$> err "test"
|
||
return $ ["--foo", "--bar"] === completions
|
||
Failure _ -> return $ counterexample "unexpected failure" failed
|
||
Success val -> return $ counterexample ("unexpected result " ++ show val) failed
|
||
|
||
prop_completion_opt_after_double_dash :: Property
|
||
prop_completion_opt_after_double_dash = once . ioProperty $
|
||
let p = (,)
|
||
<$> strOption (long "foo" <> value "")
|
||
<*> argument readerAsk (completeWith ["bar"])
|
||
i = info p idm
|
||
result = run i ["--bash-completion-index", "2"
|
||
, "--bash-completion-word", "test"
|
||
, "--bash-completion-word", "--"]
|
||
in case result of
|
||
CompletionInvoked (CompletionResult err) -> do
|
||
completions <- lines <$> err "test"
|
||
return $ ["bar"] === completions
|
||
Failure _ -> return $ counterexample "unexpected failure" failed
|
||
Success val -> return $ counterexample ("unexpected result " ++ show val) failed
|
||
|
||
prop_completion_only_reachable :: Property
|
||
prop_completion_only_reachable = once . ioProperty $
|
||
let p :: Parser (String,String)
|
||
p = (,)
|
||
<$> strArgument (completeWith ["reachable"])
|
||
<*> strArgument (completeWith ["unreachable"])
|
||
i = info p idm
|
||
result = run i ["--bash-completion-index", "0"]
|
||
in case result of
|
||
CompletionInvoked (CompletionResult err) -> do
|
||
completions <- lines <$> err "test"
|
||
return $ ["reachable"] === completions
|
||
Failure _ -> return $ counterexample "unexpected failure" failed
|
||
Success val -> return $ counterexample ("unexpected result " ++ show val) failed
|
||
|
||
prop_completion_only_reachable_deep :: Property
|
||
prop_completion_only_reachable_deep = once . ioProperty $
|
||
let p :: Parser (String,String)
|
||
p = (,)
|
||
<$> strArgument (completeWith ["seen"])
|
||
<*> strArgument (completeWith ["now-reachable"])
|
||
i = info p idm
|
||
result = run i [ "--bash-completion-index", "2"
|
||
, "--bash-completion-word", "test-prog"
|
||
, "--bash-completion-word", "seen" ]
|
||
in case result of
|
||
CompletionInvoked (CompletionResult err) -> do
|
||
completions <- lines <$> err "test"
|
||
return $ ["now-reachable"] === completions
|
||
Failure _ -> return $ counterexample "unexpected failure" failed
|
||
Success val -> return $ counterexample ("unexpected result " ++ show val) failed
|
||
|
||
prop_completion_multi :: Property
|
||
prop_completion_multi = once . ioProperty $
|
||
let p :: Parser [String]
|
||
p = many (strArgument (completeWith ["reachable"]))
|
||
i = info p idm
|
||
result = run i [ "--bash-completion-index", "3"
|
||
, "--bash-completion-word", "test-prog"
|
||
, "--bash-completion-word", "nope" ]
|
||
in case result of
|
||
CompletionInvoked (CompletionResult err) -> do
|
||
completions <- lines <$> err "test"
|
||
return $ ["reachable"] === completions
|
||
Failure _ -> return $ counterexample "unexpected failure" failed
|
||
Success val -> return $ counterexample ("unexpected result " ++ show val) failed
|
||
|
||
prop_completion_rich :: Property
|
||
prop_completion_rich = once . ioProperty $
|
||
let p = (,)
|
||
<$> option readerAsk (long "foo" <> help "Fo?")
|
||
<*> option readerAsk (long "bar" <> help "Ba?")
|
||
i = info p idm
|
||
result = run i ["--bash-completion-enriched", "--bash-completion-index", "0"]
|
||
in case result of
|
||
CompletionInvoked (CompletionResult err) -> do
|
||
completions <- lines <$> err "test"
|
||
return $ ["--foo\tFo?", "--bar\tBa?"] === completions
|
||
Failure _ -> return $ counterexample "unexpected failure" failed
|
||
Success val -> return $ counterexample ("unexpected result " ++ show val) failed
|
||
|
||
prop_completion_rich_lengths :: Property
|
||
prop_completion_rich_lengths = once . ioProperty $
|
||
let p = (,)
|
||
<$> option readerAsk (long "foo" <> help "Foo hide this")
|
||
<*> option readerAsk (long "bar" <> help "Bar hide this")
|
||
i = info p idm
|
||
result = run i [ "--bash-completion-enriched"
|
||
, "--bash-completion-index=0"
|
||
, "--bash-completion-option-desc-length=3"
|
||
, "--bash-completion-command-desc-length=30"]
|
||
in case result of
|
||
CompletionInvoked (CompletionResult err) -> do
|
||
completions <- lines <$> err "test"
|
||
return $ ["--foo\tFoo...", "--bar\tBar..."] === completions
|
||
Failure _ -> return $ counterexample "unexpected failure" failed
|
||
Success val -> return $ counterexample ("unexpected result " ++ show val) failed
|
||
|
||
prop_bind_usage :: Property
|
||
prop_bind_usage = once $
|
||
let p :: Parser [String]
|
||
p = many (argument str (metavar "ARGS..."))
|
||
i = info (p <**> helper) briefDesc
|
||
result = run i ["--help"]
|
||
in assertError result $ \failure ->
|
||
let text = head . lines . fst $ renderFailure failure "test"
|
||
in "Usage: test [ARGS...]" === text
|
||
|
||
prop_issue_19 :: Property
|
||
prop_issue_19 = once $
|
||
let p = option (fmap Just str)
|
||
( short 'x'
|
||
<> value Nothing )
|
||
i = info (p <**> helper) idm
|
||
result = run i ["-x", "foo"]
|
||
in assertResult result (Just "foo" ===)
|
||
|
||
prop_arguments1_none :: Property
|
||
prop_arguments1_none =
|
||
let p :: Parser [String]
|
||
p = some (argument str idm)
|
||
i = info (p <**> helper) idm
|
||
result = run i []
|
||
in assertError result $ \_ -> property succeeded
|
||
|
||
prop_arguments1_some :: Property
|
||
prop_arguments1_some = once $
|
||
let p :: Parser [String]
|
||
p = some (argument str idm)
|
||
i = info (p <**> helper) idm
|
||
result = run i ["foo", "--", "bar", "baz"]
|
||
in assertResult result (["foo", "bar", "baz"] ===)
|
||
|
||
prop_arguments_switch :: Property
|
||
prop_arguments_switch = once $
|
||
let p :: Parser [String]
|
||
p = switch (short 'x')
|
||
*> many (argument str idm)
|
||
i = info p idm
|
||
result = run i ["--", "-x"]
|
||
in assertResult result $ \args -> ["-x"] === args
|
||
|
||
prop_issue_35 :: Property
|
||
prop_issue_35 = once $
|
||
let p = flag' True (short 't' <> hidden)
|
||
<|> flag' False (short 'f')
|
||
i = info p idm
|
||
result = run i []
|
||
in assertError result $ \failure ->
|
||
let text = lines . fst $ renderFailure failure "test"
|
||
in ["Missing: -f", "", "Usage: test -f"] === text
|
||
|
||
prop_backtracking :: Property
|
||
prop_backtracking = once $
|
||
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"]
|
||
in assertError result $ \_ -> property succeeded
|
||
|
||
prop_subparser_inline :: Property
|
||
prop_subparser_inline = once $
|
||
let p2 = switch (short 'a')
|
||
p1 = (,)
|
||
<$> subparser (command "c" (info p2 idm))
|
||
<*> switch (short 'b')
|
||
i = info (p1 <**> helper) idm
|
||
result = execParserPure (prefs subparserInline) i ["c", "-b", "-a" ]
|
||
in assertResult result ((True, True) ===)
|
||
|
||
prop_error_context :: Property
|
||
prop_error_context = once $
|
||
let p = pk <$> option auto (long "port")
|
||
<*> option auto (long "key")
|
||
i = info p idm
|
||
result = run i ["--port", "foo", "--key", "291"]
|
||
in assertError result $ \failure ->
|
||
let (msg, _) = renderFailure failure "test"
|
||
errMsg = head $ lines msg
|
||
in conjoin [ counterexample "no context in error message (option)" ("port" `isInfixOf` errMsg)
|
||
, counterexample "no context in error message (value)" ("foo" `isInfixOf` errMsg)]
|
||
where
|
||
pk :: Int -> Int -> (Int, Int)
|
||
pk = (,)
|
||
|
||
condr :: (Int -> Bool) -> ReadM Int
|
||
condr f = do
|
||
x <- auto
|
||
guard (f x)
|
||
return x
|
||
|
||
prop_arg_order_1 :: Property
|
||
prop_arg_order_1 = once $
|
||
let p = (,)
|
||
<$> argument (condr even) idm
|
||
<*> argument (condr odd) idm
|
||
i = info p idm
|
||
result = run i ["3", "6"]
|
||
in assertError result $ \_ -> property succeeded
|
||
|
||
prop_arg_order_2 :: Property
|
||
prop_arg_order_2 = once $
|
||
let p = (,,)
|
||
<$> argument (condr even) idm
|
||
<*> option (condr even) (short 'a')
|
||
<*> option (condr odd) (short 'b')
|
||
i = info p idm
|
||
result = run i ["2", "-b", "3", "-a", "6"]
|
||
in assertResult result ((===) (2, 6, 3))
|
||
|
||
prop_arg_order_3 :: Property
|
||
prop_arg_order_3 = once $
|
||
let p = (,)
|
||
<$> ( argument (condr even) idm
|
||
<|> option auto (short 'n') )
|
||
<*> argument (condr odd) idm
|
||
i = info p idm
|
||
result = run i ["-n", "3", "5"]
|
||
in assertResult result ((===) (3, 5))
|
||
|
||
prop_unix_style :: Int -> Int -> Property
|
||
prop_unix_style j k =
|
||
let p = (,)
|
||
<$> flag' j (short 'x')
|
||
<*> flag' k (short 'c')
|
||
i = info p idm
|
||
result = run i ["-xc"]
|
||
in assertResult result ((===) (j,k))
|
||
|
||
prop_unix_with_options :: Property
|
||
prop_unix_with_options = once $
|
||
let p = (,)
|
||
<$> flag' (1 :: Int) (short 'x')
|
||
<*> strOption (short 'a')
|
||
i = info p idm
|
||
result = run i ["-xac"]
|
||
in assertResult result ((===) (1, "c"))
|
||
|
||
prop_count_flags :: Property
|
||
prop_count_flags = once $
|
||
let p = length <$> many (flag' () (short 't'))
|
||
i = info p idm
|
||
result = run i ["-ttt"]
|
||
in assertResult result ((===) 3)
|
||
|
||
prop_issue_47 :: Property
|
||
prop_issue_47 = once $
|
||
let p = option r (long "test" <> value 9) :: Parser Int
|
||
r = readerError "error message"
|
||
result = run (info p idm) ["--test", "x"]
|
||
in assertError result $ \failure ->
|
||
let text = head . lines . fst $ renderFailure failure "test"
|
||
in counterexample "no error message" ("error message" `isInfixOf` text)
|
||
|
||
prop_long_help :: Property
|
||
prop_long_help = once $
|
||
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" ]) )
|
||
in checkHelpTextWith ExitSuccess (prefs (columns 50)) "formatting" i ["--help"]
|
||
|
||
prop_issue_50 :: Property
|
||
prop_issue_50 = once $
|
||
let p = argument str (metavar "INPUT")
|
||
<* switch (long "version")
|
||
result = run (info p idm) ["--version", "test"]
|
||
in assertResult result $ \r -> "test" === r
|
||
|
||
prop_intersperse_1 :: Property
|
||
prop_intersperse_1 = once $
|
||
let p = many (argument str (metavar "ARGS"))
|
||
<* switch (short 'x')
|
||
result = run (info p noIntersperse)
|
||
["a", "-x", "b"]
|
||
in assertResult result $ \args -> ["a", "-x", "b"] === args
|
||
|
||
prop_intersperse_2 :: Property
|
||
prop_intersperse_2 = once $
|
||
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", "foo", "-x"]
|
||
result2 = run i ["test", "bar", "-x"]
|
||
in conjoin [ assertResult result1 $ \args -> ["foo", "-x"] === args
|
||
, assertError result2 $ \_ -> property succeeded ]
|
||
|
||
prop_intersperse_3 :: Property
|
||
prop_intersperse_3 = once $
|
||
let p = (,,) <$> switch ( long "foo" )
|
||
<*> strArgument ( metavar "FILE" )
|
||
<*> many ( strArgument ( metavar "ARGS..." ) )
|
||
i = info p noIntersperse
|
||
result = run i ["--foo", "myfile", "-a", "-b", "-c"]
|
||
in assertResult result $ \(b,f,as) ->
|
||
conjoin [ ["-a", "-b", "-c"] === as
|
||
, True === b
|
||
, "myfile" === f ]
|
||
|
||
prop_forward_options :: Property
|
||
prop_forward_options = once $
|
||
let p = (,) <$> switch ( long "foo" )
|
||
<*> many ( strArgument ( metavar "ARGS..." ) )
|
||
i = info p forwardOptions
|
||
result = run i ["--fo", "--foo", "myfile"]
|
||
in assertResult result $ \(b,a) ->
|
||
conjoin [ True === b
|
||
, ["--fo", "myfile"] === a ]
|
||
|
||
prop_issue_52 :: Property
|
||
prop_issue_52 = once $
|
||
let p = subparser
|
||
( metavar "FOO"
|
||
<> command "run" (info (pure "foo") idm) )
|
||
i = info p idm
|
||
in assertError (run i []) $ \failure -> do
|
||
let text = lines . fst $ renderFailure failure "test"
|
||
["Missing: FOO", "", "Usage: test FOO"] === text
|
||
|
||
prop_multiple_subparsers :: Property
|
||
prop_multiple_subparsers = once $
|
||
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
|
||
in checkHelpText "subparsers" i ["--help"]
|
||
|
||
prop_argument_error :: Property
|
||
prop_argument_error = once $
|
||
let r = (auto >>= \x -> x <$ guard (x == 42))
|
||
<|> (str >>= \x -> readerError (x ++ " /= 42"))
|
||
p1 = argument r idm :: Parser Int
|
||
i = info (p1 *> p1) idm
|
||
in assertError (run i ["3", "4"]) $ \failure ->
|
||
let text = head . lines . fst $ renderFailure failure "test"
|
||
in "3 /= 42" === text
|
||
|
||
prop_reader_error_mplus :: Property
|
||
prop_reader_error_mplus = once $
|
||
let r = (auto >>= \x -> x <$ guard (x == 42))
|
||
<|> (str >>= \x -> readerError (x ++ " /= 42"))
|
||
p1 = argument r idm :: Parser Int
|
||
i = info p1 idm
|
||
in assertError (run i ["foo"]) $ \failure ->
|
||
let text = head . lines . fst $ renderFailure failure "test"
|
||
in "foo /= 42" === text
|
||
|
||
prop_missing_flags_described :: Property
|
||
prop_missing_flags_described = once $
|
||
let p :: Parser (String, String, Maybe String)
|
||
p = (,,)
|
||
<$> option str (short 'a')
|
||
<*> option str (short 'b')
|
||
<*> optional (option str (short 'c'))
|
||
i = info p idm
|
||
in assertError (run i ["-b", "3"]) $ \failure ->
|
||
let text = head . lines . fst $ renderFailure failure "test"
|
||
in "Missing: -a ARG" === text
|
||
|
||
prop_many_missing_flags_described :: Property
|
||
prop_many_missing_flags_described = once $
|
||
let p :: Parser (String, String)
|
||
p = (,)
|
||
<$> option str (short 'a')
|
||
<*> option str (short 'b')
|
||
i = info p idm
|
||
in assertError (run i []) $ \failure ->
|
||
let text = head . lines . fst $ renderFailure failure "test"
|
||
in "Missing: -a ARG -b ARG" === text
|
||
|
||
prop_alt_missing_flags_described :: Property
|
||
prop_alt_missing_flags_described = once $
|
||
let p :: Parser String
|
||
p = option str (short 'a') <|> option str (short 'b')
|
||
i = info p idm
|
||
in assertError (run i []) $ \failure ->
|
||
let text = head . lines . fst $ renderFailure failure "test"
|
||
in "Missing: (-a ARG | -b ARG)" === text
|
||
|
||
prop_missing_option_parameter_err :: Property
|
||
prop_missing_option_parameter_err = once $
|
||
let p :: Parser String
|
||
p = option str (short 'a')
|
||
i = info p idm
|
||
in assertError (run i ["-a"]) $ \failure ->
|
||
let text = head . lines . fst $ renderFailure failure "test"
|
||
in "The option `-a` expects an argument." === text
|
||
|
||
prop_many_pairs_success :: Property
|
||
prop_many_pairs_success = once $
|
||
let p :: Parser [(String, String)]
|
||
p = many $ (,) <$> argument str idm <*> argument str idm
|
||
i = info p idm
|
||
nargs = 10000
|
||
result = run i (replicate nargs "foo")
|
||
in assertResult result $ \xs -> nargs `div` 2 === length xs
|
||
|
||
prop_many_pairs_failure :: Property
|
||
prop_many_pairs_failure = once $
|
||
let p :: Parser [(String, String)]
|
||
p = many $ (,) <$> argument str idm <*> argument str idm
|
||
i = info p idm
|
||
nargs = 9999
|
||
result = run i (replicate nargs "foo")
|
||
in assertError result $ \_ -> property succeeded
|
||
|
||
prop_many_pairs_lazy_progress :: Property
|
||
prop_many_pairs_lazy_progress = once $
|
||
let p :: Parser [(Maybe String, String)]
|
||
p = many $ (,) <$> optional (option str (short 'a')) <*> argument str idm
|
||
i = info p idm
|
||
result = run i ["foo", "-abar", "baz"]
|
||
in assertResult result $ \xs -> [(Just "bar", "foo"), (Nothing, "baz")] === xs
|
||
|
||
prop_suggest :: Property
|
||
prop_suggest = once $
|
||
let p2 = subparser (command "first" (info (pure ()) idm))
|
||
p1 = subparser (command "fst" (info (pure ()) idm))
|
||
p3 = subparser (command "far-off" (info (pure ()) idm))
|
||
p = p2 *> p1 *> p3
|
||
i = info p idm
|
||
result = run i ["fist"]
|
||
in assertError result $ \failure ->
|
||
let (msg, _) = renderFailure failure "prog"
|
||
in counterexample msg
|
||
$ isInfixOf "Did you mean one of these?\n first\n fst" msg
|
||
|
||
prop_bytestring_reader :: Property
|
||
prop_bytestring_reader = once $
|
||
let t = "testValue"
|
||
p :: Parser ByteString
|
||
p = argument str idm
|
||
i = info p idm
|
||
result = run i ["testValue"]
|
||
in assertResult result $ \xs -> BS8.pack t === xs
|
||
|
||
---
|
||
|
||
deriving instance Arbitrary a => Arbitrary (Chunk a)
|
||
deriving instance Eq SimpleDoc
|
||
deriving instance Show SimpleDoc
|
||
|
||
equalDocs :: Float -> Int -> Doc -> Doc -> Property
|
||
equalDocs f w d1 d2 = Doc.renderPretty f w d1
|
||
=== Doc.renderPretty f w d2
|
||
|
||
prop_listToChunk_1 :: [String] -> Property
|
||
prop_listToChunk_1 xs = isEmpty (listToChunk xs) === null xs
|
||
|
||
prop_listToChunk_2 :: [String] -> Property
|
||
prop_listToChunk_2 xs = listToChunk xs === mconcat (fmap pure xs)
|
||
|
||
prop_extractChunk_1 :: String -> Property
|
||
prop_extractChunk_1 x = extractChunk (pure x) === x
|
||
|
||
prop_extractChunk_2 :: Chunk String -> Property
|
||
prop_extractChunk_2 x = extractChunk (fmap pure x) === x
|
||
|
||
prop_stringChunk_1 :: Positive Float -> Positive Int -> String -> Property
|
||
prop_stringChunk_1 (Positive f) (Positive w) s =
|
||
equalDocs f w (extractChunk (stringChunk s))
|
||
(Doc.string s)
|
||
|
||
prop_stringChunk_2 :: String -> Property
|
||
prop_stringChunk_2 s = isEmpty (stringChunk s) === null s
|
||
|
||
prop_paragraph :: String -> Property
|
||
prop_paragraph s = isEmpty (paragraph s) === null (words s)
|
||
|
||
---
|
||
|
||
--
|
||
-- From
|
||
-- https://en.wikipedia.org/wiki/Damerau%E2%80%93Levenshtein_distance
|
||
--
|
||
-- In information theory and computer science, the Damerau–Levenshtein
|
||
-- distance is a distance (string metric) between two strings, i.e.,
|
||
-- finite sequence of symbols, given by counting the minimum number
|
||
-- of operations needed to transform one string into the other, where
|
||
-- an operation is defined as an insertion, deletion, or substitution
|
||
-- of a single character, or a transposition of two adjacent characters.
|
||
--
|
||
prop_edit_distance_gezero :: String -> String -> Bool
|
||
prop_edit_distance_gezero a b = editDistance a b >= 0
|
||
|
||
prop_edit_insertion :: [Char] -> Char -> [Char] -> Property
|
||
prop_edit_insertion as i bs =
|
||
editDistance (as ++ bs) (as ++ [i] ++ bs) === 1
|
||
|
||
prop_edit_symmetric :: [Char] -> [Char] -> Property
|
||
prop_edit_symmetric as bs =
|
||
editDistance as bs === editDistance bs as
|
||
|
||
prop_edit_substitution :: [Char] -> [Char] -> Char -> Char -> Property
|
||
prop_edit_substitution as bs a b = a /= b ==>
|
||
editDistance (as ++ [a] ++ bs) (as ++ [b] ++ bs) === 1
|
||
|
||
prop_edit_transposition :: [Char] -> [Char] -> Char -> Char -> Property
|
||
prop_edit_transposition as bs a b = a /= b ==>
|
||
editDistance (as ++ [a,b] ++ bs) (as ++ [b,a] ++ bs) === 1
|
||
|
||
---
|
||
|
||
return []
|
||
main :: IO ()
|
||
main = do
|
||
result <- $(quickCheckAll)
|
||
unless result exitFailure
|