1{-# LANGUAGE StandaloneDeriving #-} 2{-# LANGUAGE GeneralizedNewtypeDeriving #-} 3{-# LANGUAGE TemplateHaskell #-} 4{-# OPTIONS_GHC -fno-warn-orphans #-} 5module Main where 6 7import qualified Examples.Hello as Hello 8import qualified Examples.Commands as Commands 9import qualified Examples.Cabal as Cabal 10import qualified Examples.Alternatives as Alternatives 11import qualified Examples.Formatting as Formatting 12 13import Control.Applicative 14import Control.Monad 15import Data.List hiding (group) 16import Data.List.NonEmpty (NonEmpty ((:|))) 17import Data.Semigroup hiding (option) 18import Data.String 19 20import System.Exit 21import Test.QuickCheck hiding (Success, Failure) 22import Test.QuickCheck.Property 23 24import Options.Applicative 25import Options.Applicative.Types 26import qualified Options.Applicative.NonEmpty 27 28 29import qualified Options.Applicative.Help as H 30import Options.Applicative.Help.Pretty (Doc, SimpleDoc(..)) 31import qualified Options.Applicative.Help.Pretty as Doc 32import Options.Applicative.Help.Chunk 33import Options.Applicative.Help.Levenshtein 34 35import Prelude 36 37run :: ParserInfo a -> [String] -> ParserResult a 38run = execParserPure defaultPrefs 39 40assertError :: Show a => ParserResult a 41 -> (ParserFailure ParserHelp -> Property) -> Property 42assertError x f = case x of 43 Success r -> counterexample ("expected failure, got success: " ++ show r) failed 44 Failure e -> f e 45 CompletionInvoked _ -> counterexample "expected failure, got completion" failed 46 47assertResult :: ParserResult a -> (a -> Property) -> Property 48assertResult x f = case x of 49 Success r -> f r 50 Failure e -> do 51 let (msg, _) = renderFailure e "test" 52 counterexample ("unexpected parse error\n" ++ msg) failed 53 CompletionInvoked _ -> counterexample "expected result, got completion" failed 54 55assertHasLine :: String -> String -> Property 56assertHasLine l s = counterexample ("expected line:\n\t" ++ l ++ "\nnot found") 57 $ l `elem` lines s 58 59checkHelpTextWith :: Show a => ExitCode -> ParserPrefs -> String 60 -> ParserInfo a -> [String] -> Property 61checkHelpTextWith ecode pprefs name p args = ioProperty $ do 62 let result = execParserPure pprefs p args 63 expected <- readFile $ "tests/" ++ name ++ ".err.txt" 64 return $ assertError result $ \failure -> 65 let (msg, code) = renderFailure failure name 66 in (expected === msg ++ "\n") .&&. (ecode === code) 67 68checkHelpText :: Show a => String -> ParserInfo a -> [String] -> Property 69checkHelpText = checkHelpTextWith ExitSuccess defaultPrefs 70 71prop_hello :: Property 72prop_hello = once $ 73 checkHelpText "hello" Hello.opts ["--help"] 74 75prop_modes :: Property 76prop_modes = once $ 77 checkHelpText "commands" Commands.opts ["--help"] 78 79prop_cmd_header :: Property 80prop_cmd_header = once $ 81 let i = info (helper <*> Commands.sample) (header "foo") 82 r1 = checkHelpTextWith (ExitFailure 1) defaultPrefs 83 "commands_header" i ["-zello"] 84 r2 = checkHelpTextWith (ExitFailure 1) (prefs showHelpOnError) 85 "commands_header_full" i ["-zello"] 86 in (r1 .&&. r2) 87 88prop_cabal_conf :: Property 89prop_cabal_conf = once $ 90 checkHelpTextWith ExitSuccess (prefs helpShowGlobals) "cabal" Cabal.pinfo ["configure", "--help"] 91 92prop_args :: Property 93prop_args = once $ 94 let result = run Commands.opts ["hello", "foo", "bar"] 95 in assertResult result ((===) (Commands.Hello ["foo", "bar"])) 96 97prop_args_opts :: Property 98prop_args_opts = once $ 99 let result = run Commands.opts ["hello", "foo", "--bar"] 100 in assertError result (\_ -> property succeeded) 101 102prop_args_ddash :: Property 103prop_args_ddash = once $ 104 let result = run Commands.opts ["hello", "foo", "--", "--bar", "--", "baz"] 105 in assertResult result ((===) (Commands.Hello ["foo", "--bar", "--", "baz"])) 106 107prop_alts :: Property 108prop_alts = once $ 109 let result = run Alternatives.opts ["-b", "-a", "-b", "-a", "-a", "-b"] 110 in assertResult result $ \xs -> 111 let a = Alternatives.A 112 b = Alternatives.B 113 in [b, a, b, a, a, b] === xs 114 115prop_show_default :: Property 116prop_show_default = once $ 117 let p = option auto 118 ( short 'n' 119 <> help "set count" 120 <> value (0 :: Int) 121 <> showDefault ) 122 i = info (p <**> helper) idm 123 result = run i ["--help"] 124 in assertError result $ \failure -> 125 let (msg, _) = renderFailure failure "test" 126 in assertHasLine 127 " -n ARG set count (default: 0)" 128 msg 129 130prop_alt_cont :: Property 131prop_alt_cont = once $ 132 let p = Alternatives.a <|> Alternatives.b 133 i = info p idm 134 result = run i ["-a", "-b"] 135 in assertError result (\_ -> property succeeded) 136 137prop_alt_help :: Property 138prop_alt_help = once $ 139 let p :: Parser (Maybe (Either String String)) 140 p = p1 <|> p2 <|> p3 141 p1 = (Just . Left) 142 <$> strOption ( long "virtual-machine" 143 <> metavar "VM" 144 <> help "Virtual machine name" ) 145 p2 = (Just . Right) 146 <$> strOption ( long "cloud-service" 147 <> metavar "CS" 148 <> help "Cloud service name" ) 149 p3 = flag' Nothing ( long "dry-run" ) 150 i = info (p <**> helper) idm 151 in checkHelpText "alt" i ["--help"] 152 153prop_optional_help :: Property 154prop_optional_help = once $ 155 let p :: Parser (Maybe (String, String)) 156 p = optional ((,) 157 <$> strOption ( long "a" 158 <> metavar "A" 159 <> help "value a" ) 160 <*> strOption ( long "b" 161 <> metavar "B" 162 <> help "value b" ) ) 163 i = info (p <**> helper) idm 164 in checkHelpText "optional" i ["--help"] 165 166prop_optional_requiring_parens :: Property 167prop_optional_requiring_parens = once $ 168 let p = optional $ 169 (,) 170 <$> flag' () ( short 'a' <> long "a" ) 171 <*> flag' () ( short 'b' <> long "b" ) 172 i = info (p <**> helper) briefDesc 173 result = run i ["--help"] 174 in assertError result $ \failure -> 175 let text = head . lines . fst $ renderFailure failure "test" 176 in "Usage: test [(-a|--a) (-b|--b)]" === text 177 178prop_optional_alt_requiring_parens :: Property 179prop_optional_alt_requiring_parens = once $ 180 let p = optional $ 181 flag' () ( short 'a' <> long "a" ) 182 <|> flag' () ( short 'b' <> long "b" ) 183 i = info (p <**> helper) briefDesc 184 result = run i ["--help"] 185 in assertError result $ \failure -> 186 let text = head . lines . fst $ renderFailure failure "test" 187 in "Usage: test [(-a|--a) | (-b|--b)]" === text 188 189prop_nested_optional_help :: Property 190prop_nested_optional_help = once $ 191 let p :: Parser (String, Maybe (String, Maybe String)) 192 p = (,) <$> 193 (strOption ( short 'a' 194 <> long "a" 195 <> metavar "A" 196 <> help "value a" ) ) <*> 197 (optional 198 ((,) <$> 199 (strOption ( long "b0" 200 <> metavar "B0" 201 <> help "value b0" ) ) <*> 202 (optional (strOption ( long "b1" 203 <> metavar "B1" 204 <> help "value b1" ))))) 205 i = info (p <**> helper) idm 206 in checkHelpText "nested_optional" i ["--help"] 207 208prop_long_equals :: Property 209prop_long_equals = once $ 210 let p :: Parser String 211 p = option auto ( long "intval" 212 <> short 'j' 213 <> long "intval2" 214 <> short 'i' 215 <> help "integer value") 216 i = info (p <**> helper) fullDesc 217 in checkHelpTextWith ExitSuccess (prefs helpLongEquals) "long_equals" i ["--help"] 218 219prop_long_equals_doesnt_do_shorts :: Property 220prop_long_equals_doesnt_do_shorts = once $ 221 let p :: Parser String 222 p = option auto ( short 'i' 223 <> help "integer value") 224 i = info (p <**> helper) fullDesc 225 result = execParserPure (prefs helpLongEquals) i ["--help"] 226 in assertError result $ \failure -> 227 let text = head . lines . fst $ renderFailure failure "test" 228 in "Usage: test -i ARG" === text 229 230prop_nested_fun :: Property 231prop_nested_fun = once $ 232 let p :: Parser (String, Maybe (String, Maybe String)) 233 p = (,) <$> 234 (strOption (short 'a' <> long "a" <> metavar "A")) <*> 235 (optional 236 ((,) <$> 237 (strOption (short 'b' <> long "b" <> metavar "B")) <*> 238 (optional (strOption (short 'c' <> long "c" <> metavar "C"))))) 239 i = info (p <**> helper) briefDesc 240 result = run i ["--help"] 241 in assertError result $ \failure -> 242 let text = head . lines . fst $ renderFailure failure "test" 243 in "Usage: test (-a|--a A) [(-b|--b B) [-c|--c C]]" === text 244 245prop_nested_commands :: Property 246prop_nested_commands = once $ 247 let p3 :: Parser String 248 p3 = strOption (short 'a' <> metavar "A") 249 p2 = subparser (command "b" (info p3 idm)) 250 p1 = subparser (command "c" (info p2 idm)) 251 i = info (p1 <**> helper) idm 252 in checkHelpTextWith (ExitFailure 1) defaultPrefs "nested" i ["c", "b"] 253 254prop_drops_back_contexts :: Property 255prop_drops_back_contexts = once $ 256 let p3 :: Parser String 257 p3 = strOption (short 'a' <> metavar "A") 258 p2 = subparser (command "b" (info p3 idm) <> metavar "B") 259 p1 = subparser (command "c" (info p3 idm) <> metavar "C") 260 p0 = (,) <$> p2 <*> p1 261 i = info (p0 <**> helper) idm 262 in checkHelpTextWith (ExitFailure 1) defaultPrefs "dropback" i ["b", "-aA"] 263 264prop_context_carry :: Property 265prop_context_carry = once $ 266 let p3 :: Parser String 267 p3 = strOption (short 'a' <> metavar "A") 268 p2 = subparser (command "b" (info p3 idm) <> metavar "B") 269 p1 = subparser (command "c" (info p3 idm) <> metavar "C") 270 p0 = (,) <$> p2 <*> p1 271 i = info (p0 <**> helper) idm 272 in checkHelpTextWith (ExitFailure 1) defaultPrefs "carry" i ["b", "-aA", "c"] 273 274prop_help_on_empty :: Property 275prop_help_on_empty = once $ 276 let p3 :: Parser String 277 p3 = strOption (short 'a' <> metavar "A") 278 p2 = subparser (command "b" (info p3 idm) <> metavar "B") 279 p1 = subparser (command "c" (info p3 idm) <> metavar "C") 280 p0 = (,) <$> p2 <*> p1 281 i = info (p0 <**> helper) idm 282 in checkHelpTextWith (ExitFailure 1) (prefs showHelpOnEmpty) "helponempty" i [] 283 284prop_help_on_empty_sub :: Property 285prop_help_on_empty_sub = once $ 286 let p3 :: Parser String 287 p3 = strOption (short 'a' <> metavar "A" <> help "both commands require this") 288 p2 = subparser (command "b" (info p3 idm) <> metavar "B") 289 p1 = subparser (command "c" (info p3 idm) <> metavar "C") 290 p0 = (,) <$> p2 <*> p1 291 i = info (p0 <**> helper) idm 292 in checkHelpTextWith (ExitFailure 1) (prefs showHelpOnEmpty) "helponemptysub" i ["b", "-aA", "c"] 293 294prop_many_args :: Property 295prop_many_args = forAll (choose (0,2000)) $ \nargs -> 296 let p :: Parser [String] 297 p = many (argument str idm) 298 i = info p idm 299 result = run i (replicate nargs "foo") 300 in assertResult result (\xs -> nargs === length xs) 301 302prop_disambiguate :: Property 303prop_disambiguate = once $ 304 let p = flag' (1 :: Int) (long "foo") 305 <|> flag' 2 (long "bar") 306 <|> flag' 3 (long "baz") 307 i = info p idm 308 result = execParserPure (prefs disambiguate) i ["--f"] 309 in assertResult result ((===) 1) 310 311prop_ambiguous :: Property 312prop_ambiguous = once $ 313 let p = flag' (1 :: Int) (long "foo") 314 <|> flag' 2 (long "bar") 315 <|> flag' 3 (long "baz") 316 i = info p idm 317 result = execParserPure (prefs disambiguate) i ["--ba"] 318 in assertError result (\_ -> property succeeded) 319 320prop_completion :: Property 321prop_completion = once . ioProperty $ 322 let p = (,) 323 <$> strOption (long "foo" <> value "") 324 <*> strOption (long "bar" <> value "") 325 i = info p idm 326 result = run i ["--bash-completion-index", "0"] 327 in case result of 328 CompletionInvoked (CompletionResult err) -> do 329 completions <- lines <$> err "test" 330 return $ ["--foo", "--bar"] === completions 331 Failure _ -> return $ counterexample "unexpected failure" failed 332 Success val -> return $ counterexample ("unexpected result " ++ show val) failed 333 334prop_completion_opt_after_double_dash :: Property 335prop_completion_opt_after_double_dash = once . ioProperty $ 336 let p = (,) 337 <$> strOption (long "foo" <> value "") 338 <*> argument readerAsk (completeWith ["bar"]) 339 i = info p idm 340 result = run i ["--bash-completion-index", "2" 341 , "--bash-completion-word", "test" 342 , "--bash-completion-word", "--"] 343 in case result of 344 CompletionInvoked (CompletionResult err) -> do 345 completions <- lines <$> err "test" 346 return $ ["bar"] === completions 347 Failure _ -> return $ counterexample "unexpected failure" failed 348 Success val -> return $ counterexample ("unexpected result " ++ show val) failed 349 350prop_completion_only_reachable :: Property 351prop_completion_only_reachable = once . ioProperty $ 352 let p :: Parser (String,String) 353 p = (,) 354 <$> strArgument (completeWith ["reachable"]) 355 <*> strArgument (completeWith ["unreachable"]) 356 i = info p idm 357 result = run i ["--bash-completion-index", "0"] 358 in case result of 359 CompletionInvoked (CompletionResult err) -> do 360 completions <- lines <$> err "test" 361 return $ ["reachable"] === completions 362 Failure _ -> return $ counterexample "unexpected failure" failed 363 Success val -> return $ counterexample ("unexpected result " ++ show val) failed 364 365prop_completion_only_reachable_deep :: Property 366prop_completion_only_reachable_deep = once . ioProperty $ 367 let p :: Parser (String,String) 368 p = (,) 369 <$> strArgument (completeWith ["seen"]) 370 <*> strArgument (completeWith ["now-reachable"]) 371 i = info p idm 372 result = run i [ "--bash-completion-index", "2" 373 , "--bash-completion-word", "test-prog" 374 , "--bash-completion-word", "seen" ] 375 in case result of 376 CompletionInvoked (CompletionResult err) -> do 377 completions <- lines <$> err "test" 378 return $ ["now-reachable"] === completions 379 Failure _ -> return $ counterexample "unexpected failure" failed 380 Success val -> return $ counterexample ("unexpected result " ++ show val) failed 381 382prop_completion_multi :: Property 383prop_completion_multi = once . ioProperty $ 384 let p :: Parser [String] 385 p = many (strArgument (completeWith ["reachable"])) 386 i = info p idm 387 result = run i [ "--bash-completion-index", "3" 388 , "--bash-completion-word", "test-prog" 389 , "--bash-completion-word", "nope" ] 390 in case result of 391 CompletionInvoked (CompletionResult err) -> do 392 completions <- lines <$> err "test" 393 return $ ["reachable"] === completions 394 Failure _ -> return $ counterexample "unexpected failure" failed 395 Success val -> return $ counterexample ("unexpected result " ++ show val) failed 396 397prop_completion_rich :: Property 398prop_completion_rich = once . ioProperty $ 399 let p = (,) 400 <$> option readerAsk (long "foo" <> help "Fo?") 401 <*> option readerAsk (long "bar" <> help "Ba?") 402 i = info p idm 403 result = run i ["--bash-completion-enriched", "--bash-completion-index", "0"] 404 in case result of 405 CompletionInvoked (CompletionResult err) -> do 406 completions <- lines <$> err "test" 407 return $ ["--foo\tFo?", "--bar\tBa?"] === completions 408 Failure _ -> return $ counterexample "unexpected failure" failed 409 Success val -> return $ counterexample ("unexpected result " ++ show val) failed 410 411prop_completion_rich_lengths :: Property 412prop_completion_rich_lengths = once . ioProperty $ 413 let p = (,) 414 <$> option readerAsk (long "foo" <> help "Foo hide this") 415 <*> option readerAsk (long "bar" <> help "Bar hide this") 416 i = info p idm 417 result = run i [ "--bash-completion-enriched" 418 , "--bash-completion-index=0" 419 , "--bash-completion-option-desc-length=3" 420 , "--bash-completion-command-desc-length=30"] 421 in case result of 422 CompletionInvoked (CompletionResult err) -> do 423 completions <- lines <$> err "test" 424 return $ ["--foo\tFoo...", "--bar\tBar..."] === completions 425 Failure _ -> return $ counterexample "unexpected failure" failed 426 Success val -> return $ counterexample ("unexpected result " ++ show val) failed 427 428prop_bind_usage :: Property 429prop_bind_usage = once $ 430 let p :: Parser [String] 431 p = many (argument str (metavar "ARGS...")) 432 i = info (p <**> helper) briefDesc 433 result = run i ["--help"] 434 in assertError result $ \failure -> 435 let text = head . lines . fst $ renderFailure failure "test" 436 in "Usage: test [ARGS...]" === text 437 438prop_issue_19 :: Property 439prop_issue_19 = once $ 440 let p = option (fmap Just str) 441 ( short 'x' 442 <> value Nothing ) 443 i = info (p <**> helper) idm 444 result = run i ["-x", "foo"] 445 in assertResult result (Just "foo" ===) 446 447prop_arguments1_none :: Property 448prop_arguments1_none = 449 let p :: Parser [String] 450 p = some (argument str idm) 451 i = info (p <**> helper) idm 452 result = run i [] 453 in assertError result $ \_ -> property succeeded 454 455prop_arguments1_some :: Property 456prop_arguments1_some = once $ 457 let p :: Parser [String] 458 p = some (argument str idm) 459 i = info (p <**> helper) idm 460 result = run i ["foo", "--", "bar", "baz"] 461 in assertResult result (["foo", "bar", "baz"] ===) 462 463prop_arguments_switch :: Property 464prop_arguments_switch = once $ 465 let p :: Parser [String] 466 p = switch (short 'x') 467 *> many (argument str idm) 468 i = info p idm 469 result = run i ["--", "-x"] 470 in assertResult result $ \args -> ["-x"] === args 471 472prop_issue_35 :: Property 473prop_issue_35 = once $ 474 let p = flag' True (short 't' <> hidden) 475 <|> flag' False (short 'f') 476 i = info p idm 477 result = run i [] 478 in assertError result $ \failure -> 479 let text = lines . fst $ renderFailure failure "test" 480 in ["Missing: -f", "", "Usage: test -f"] === text 481 482prop_backtracking :: Property 483prop_backtracking = once $ 484 let p2 = switch (short 'a') 485 p1 = (,) 486 <$> subparser (command "c" (info p2 idm)) 487 <*> switch (short 'b') 488 i = info (p1 <**> helper) idm 489 result = execParserPure (prefs noBacktrack) i ["c", "-b"] 490 in assertError result $ \_ -> property succeeded 491 492prop_subparser_inline :: Property 493prop_subparser_inline = once $ 494 let p2 = switch (short 'a') 495 p1 = (,) 496 <$> subparser (command "c" (info p2 idm)) 497 <*> switch (short 'b') 498 i = info (p1 <**> helper) idm 499 result = execParserPure (prefs subparserInline) i ["c", "-b", "-a" ] 500 in assertResult result ((True, True) ===) 501 502prop_error_context :: Property 503prop_error_context = once $ 504 let p = pk <$> option auto (long "port") 505 <*> option auto (long "key") 506 i = info p idm 507 result = run i ["--port", "foo", "--key", "291"] 508 in assertError result $ \failure -> 509 let (msg, _) = renderFailure failure "test" 510 errMsg = head $ lines msg 511 in conjoin [ counterexample "no context in error message (option)" ("port" `isInfixOf` errMsg) 512 , counterexample "no context in error message (value)" ("foo" `isInfixOf` errMsg)] 513 where 514 pk :: Int -> Int -> (Int, Int) 515 pk = (,) 516 517condr :: (Int -> Bool) -> ReadM Int 518condr f = do 519 x <- auto 520 guard (f x) 521 return x 522 523prop_arg_order_1 :: Property 524prop_arg_order_1 = once $ 525 let p = (,) 526 <$> argument (condr even) idm 527 <*> argument (condr odd) idm 528 i = info p idm 529 result = run i ["3", "6"] 530 in assertError result $ \_ -> property succeeded 531 532prop_arg_order_2 :: Property 533prop_arg_order_2 = once $ 534 let p = (,,) 535 <$> argument (condr even) idm 536 <*> option (condr even) (short 'a') 537 <*> option (condr odd) (short 'b') 538 i = info p idm 539 result = run i ["2", "-b", "3", "-a", "6"] 540 in assertResult result ((===) (2, 6, 3)) 541 542prop_arg_order_3 :: Property 543prop_arg_order_3 = once $ 544 let p = (,) 545 <$> ( argument (condr even) idm 546 <|> option auto (short 'n') ) 547 <*> argument (condr odd) idm 548 i = info p idm 549 result = run i ["-n", "3", "5"] 550 in assertResult result ((===) (3, 5)) 551 552prop_unix_style :: Int -> Int -> Property 553prop_unix_style j k = 554 let p = (,) 555 <$> flag' j (short 'x') 556 <*> flag' k (short 'c') 557 i = info p idm 558 result = run i ["-xc"] 559 in assertResult result ((===) (j,k)) 560 561prop_unix_with_options :: Property 562prop_unix_with_options = once $ 563 let p = (,) 564 <$> flag' (1 :: Int) (short 'x') 565 <*> strOption (short 'a') 566 i = info p idm 567 result = run i ["-xac"] 568 in assertResult result ((===) (1, "c")) 569 570prop_count_flags :: Property 571prop_count_flags = once $ 572 let p = length <$> many (flag' () (short 't')) 573 i = info p idm 574 result = run i ["-ttt"] 575 in assertResult result ((===) 3) 576 577prop_issue_47 :: Property 578prop_issue_47 = once $ 579 let p = option r (long "test" <> value 9) :: Parser Int 580 r = readerError "error message" 581 result = run (info p idm) ["--test", "x"] 582 in assertError result $ \failure -> 583 let text = head . lines . fst $ renderFailure failure "test" 584 in counterexample "no error message" ("error message" `isInfixOf` text) 585 586prop_long_help :: Property 587prop_long_help = once $ 588 let p = Formatting.opts <**> helper 589 i = info p 590 ( progDesc (concat 591 [ "This is a very long program description. " 592 , "This text should be automatically wrapped " 593 , "to fit the size of the terminal" ]) ) 594 in checkHelpTextWith ExitSuccess (prefs (columns 50)) "formatting" i ["--help"] 595 596prop_issue_50 :: Property 597prop_issue_50 = once $ 598 let p = argument str (metavar "INPUT") 599 <* switch (long "version") 600 result = run (info p idm) ["--version", "test"] 601 in assertResult result $ \r -> "test" === r 602 603prop_intersperse_1 :: Property 604prop_intersperse_1 = once $ 605 let p = many (argument str (metavar "ARGS")) 606 <* switch (short 'x') 607 result = run (info p noIntersperse) 608 ["a", "-x", "b"] 609 in assertResult result $ \args -> ["a", "-x", "b"] === args 610 611prop_intersperse_2 :: Property 612prop_intersperse_2 = once $ 613 let p = subparser 614 ( command "run" 615 ( info (many (argument str (metavar "OPTIONS"))) 616 noIntersperse ) 617 <> command "test" 618 ( info (many (argument str (metavar "ARGS"))) 619 idm ) ) 620 i = info p idm 621 result1 = run i ["run", "foo", "-x"] 622 result2 = run i ["test", "bar", "-x"] 623 in conjoin [ assertResult result1 $ \args -> ["foo", "-x"] === args 624 , assertError result2 $ \_ -> property succeeded ] 625 626prop_intersperse_3 :: Property 627prop_intersperse_3 = once $ 628 let p = (,,) <$> switch ( long "foo" ) 629 <*> strArgument ( metavar "FILE" ) 630 <*> many ( strArgument ( metavar "ARGS..." ) ) 631 i = info p noIntersperse 632 result = run i ["--foo", "myfile", "-a", "-b", "-c"] 633 in assertResult result $ \(b,f,as) -> 634 conjoin [ ["-a", "-b", "-c"] === as 635 , True === b 636 , "myfile" === f ] 637 638prop_forward_options :: Property 639prop_forward_options = once $ 640 let p = (,) <$> switch ( long "foo" ) 641 <*> many ( strArgument ( metavar "ARGS..." ) ) 642 i = info p forwardOptions 643 result = run i ["--fo", "--foo", "myfile"] 644 in assertResult result $ \(b,a) -> 645 conjoin [ True === b 646 , ["--fo", "myfile"] === a ] 647 648prop_issue_52 :: Property 649prop_issue_52 = once $ 650 let p = subparser 651 ( metavar "FOO" 652 <> command "run" (info (pure "foo") idm) ) 653 i = info p idm 654 in assertError (run i []) $ \failure -> do 655 let text = lines . fst $ renderFailure failure "test" 656 ["Missing: FOO", "", "Usage: test FOO"] === text 657 658prop_multiple_subparsers :: Property 659prop_multiple_subparsers = once $ 660 let p1 = subparser 661 (command "add" (info (pure ()) 662 ( progDesc "Add a file to the repository" ))) 663 p2 = subparser 664 (command "commit" (info (pure ()) 665 ( progDesc "Record changes to the repository" ))) 666 i = info (p1 *> p2 <**> helper) idm 667 in checkHelpText "subparsers" i ["--help"] 668 669prop_argument_error :: Property 670prop_argument_error = once $ 671 let r = (auto >>= \x -> x <$ guard (x == 42)) 672 <|> (str >>= \x -> readerError (x ++ " /= 42")) 673 p1 = argument r idm :: Parser Int 674 i = info (p1 *> p1) idm 675 in assertError (run i ["3", "4"]) $ \failure -> 676 let text = head . lines . fst $ renderFailure failure "test" 677 in "3 /= 42" === text 678 679prop_reader_error_mplus :: Property 680prop_reader_error_mplus = once $ 681 let r = (auto >>= \x -> x <$ guard (x == 42)) 682 <|> (str >>= \x -> readerError (x ++ " /= 42")) 683 p1 = argument r idm :: Parser Int 684 i = info p1 idm 685 in assertError (run i ["foo"]) $ \failure -> 686 let text = head . lines . fst $ renderFailure failure "test" 687 in "foo /= 42" === text 688 689prop_missing_flags_described :: Property 690prop_missing_flags_described = once $ 691 let p :: Parser (String, String, Maybe String) 692 p = (,,) 693 <$> option str (short 'a') 694 <*> option str (short 'b') 695 <*> optional (option str (short 'c')) 696 i = info p idm 697 in assertError (run i ["-b", "3"]) $ \failure -> 698 let text = head . lines . fst $ renderFailure failure "test" 699 in "Missing: -a ARG" === text 700 701prop_many_missing_flags_described :: Property 702prop_many_missing_flags_described = once $ 703 let p :: Parser (String, String) 704 p = (,) 705 <$> option str (short 'a') 706 <*> option str (short 'b') 707 i = info p idm 708 in assertError (run i []) $ \failure -> 709 let text = head . lines . fst $ renderFailure failure "test" 710 in "Missing: -a ARG -b ARG" === text 711 712prop_alt_missing_flags_described :: Property 713prop_alt_missing_flags_described = once $ 714 let p :: Parser String 715 p = option str (short 'a') <|> option str (short 'b') 716 i = info p idm 717 in assertError (run i []) $ \failure -> 718 let text = head . lines . fst $ renderFailure failure "test" 719 in "Missing: (-a ARG | -b ARG)" === text 720 721prop_missing_option_parameter_err :: Property 722prop_missing_option_parameter_err = once $ 723 let p :: Parser String 724 p = option str (short 'a') 725 i = info p idm 726 in assertError (run i ["-a"]) $ \failure -> 727 let text = head . lines . fst $ renderFailure failure "test" 728 in "The option `-a` expects an argument." === text 729 730prop_many_pairs_success :: Property 731prop_many_pairs_success = once $ 732 let p :: Parser [(String, String)] 733 p = many $ (,) <$> argument str idm <*> argument str idm 734 i = info p idm 735 nargs = 10000 736 result = run i (replicate nargs "foo") 737 in assertResult result $ \xs -> nargs `div` 2 === length xs 738 739prop_many_pairs_failure :: Property 740prop_many_pairs_failure = once $ 741 let p :: Parser [(String, String)] 742 p = many $ (,) <$> argument str idm <*> argument str idm 743 i = info p idm 744 nargs = 9999 745 result = run i (replicate nargs "foo") 746 in assertError result $ \_ -> property succeeded 747 748prop_many_pairs_lazy_progress :: Property 749prop_many_pairs_lazy_progress = once $ 750 let p :: Parser [(Maybe String, String)] 751 p = many $ (,) <$> optional (option str (short 'a')) <*> argument str idm 752 i = info p idm 753 result = run i ["foo", "-abar", "baz"] 754 in assertResult result $ \xs -> [(Just "bar", "foo"), (Nothing, "baz")] === xs 755 756prop_suggest :: Property 757prop_suggest = once $ 758 let p2 = subparser (command "first" (info (pure ()) idm)) 759 p1 = subparser (command "fst" (info (pure ()) idm)) 760 p3 = subparser (command "far-off" (info (pure ()) idm)) 761 p = p2 *> p1 *> p3 762 i = info p idm 763 result = run i ["fist"] 764 in assertError result $ \failure -> 765 let (msg, _) = renderFailure failure "prog" 766 in counterexample msg 767 $ isInfixOf "Did you mean one of these?\n first\n fst" msg 768 769prop_grouped_some_option_ellipsis :: Property 770prop_grouped_some_option_ellipsis = once $ 771 let x :: Parser String 772 x = strOption (short 'x' <> metavar "X") 773 p = prefs (multiSuffix "...") 774 r = show . extractChunk $ H.briefDesc p (x *> some x) 775 in r === "-x X (-x X)..." 776 777prop_grouped_many_option_ellipsis :: Property 778prop_grouped_many_option_ellipsis = once $ 779 let x :: Parser String 780 x = strOption (short 'x' <> metavar "X") 781 p = prefs (multiSuffix "...") 782 r = show . extractChunk $ H.briefDesc p (x *> many x) 783 in r === "-x X [-x X]..." 784 785prop_grouped_some_argument_ellipsis :: Property 786prop_grouped_some_argument_ellipsis = once $ 787 let x :: Parser String 788 x = strArgument (metavar "X") 789 p = prefs (multiSuffix "...") 790 r = show . extractChunk $ H.briefDesc p (x *> some x) 791 in r === "X X..." 792 793prop_grouped_many_argument_ellipsis :: Property 794prop_grouped_many_argument_ellipsis = once $ 795 let x :: Parser String 796 x = strArgument (metavar "X") 797 p = prefs (multiSuffix "...") 798 r = show . extractChunk $ H.briefDesc p (x *> many x) 799 in r === "X [X]..." 800 801prop_grouped_some_pairs_argument_ellipsis :: Property 802prop_grouped_some_pairs_argument_ellipsis = once $ 803 let x :: Parser String 804 x = strArgument (metavar "X") 805 p = prefs (multiSuffix "...") 806 r = show . extractChunk $ H.briefDesc p (x *> some (x *> x)) 807 in r === "X (X X)..." 808 809prop_grouped_many_pairs_argument_ellipsis :: Property 810prop_grouped_many_pairs_argument_ellipsis = once $ 811 let x :: Parser String 812 x = strArgument (metavar "X") 813 p = prefs (multiSuffix "...") 814 r = show . extractChunk $ H.briefDesc p (x *> many (x *> x)) 815 in r === "X [X X]..." 816 817prop_grouped_some_dual_option_ellipsis :: Property 818prop_grouped_some_dual_option_ellipsis = once $ 819 let x :: Parser String 820 x = strOption (short 'a' <> short 'b' <> metavar "X") 821 p = prefs (multiSuffix "...") 822 r = show . extractChunk $ H.briefDesc p (x *> some x) 823 in r === "(-a|-b X) (-a|-b X)..." 824 825prop_grouped_many_dual_option_ellipsis :: Property 826prop_grouped_many_dual_option_ellipsis = once $ 827 let x :: Parser String 828 x = strOption (short 'a' <> short 'b' <> metavar "X") 829 p = prefs (multiSuffix "...") 830 r = show . extractChunk $ H.briefDesc p (x *> many x) 831 in r === "(-a|-b X) [-a|-b X]..." 832 833prop_grouped_some_dual_flag_ellipsis :: Property 834prop_grouped_some_dual_flag_ellipsis = once $ 835 let x = flag' () (short 'a' <> short 'b') 836 p = prefs (multiSuffix "...") 837 r = show . extractChunk $ H.briefDesc p (x *> some x) 838 in r === "(-a|-b) (-a|-b)..." 839 840prop_grouped_many_dual_flag_ellipsis :: Property 841prop_grouped_many_dual_flag_ellipsis = once $ 842 let x = flag' () (short 'a' <> short 'b') 843 p = prefs (multiSuffix "...") 844 r = show . extractChunk $ H.briefDesc p (x *> many x) 845 in r === "(-a|-b) [-a|-b]..." 846 847prop_issue_402 :: Property 848prop_issue_402 = once $ 849 let x = some (flag' () (short 'a')) <|> some (flag' () (short 'b' <> internal)) 850 p = prefs (multiSuffix "...") 851 r = show . extractChunk $ H.briefDesc p x 852 in r === "(-a)..." 853 854prop_nice_some1 :: Property 855prop_nice_some1 = once $ 856 let x = Options.Applicative.NonEmpty.some1 (flag' () (short 'a')) 857 p = prefs (multiSuffix "...") 858 r = show . extractChunk $ H.briefDesc p x 859 in r === "(-a)..." 860 861prop_some1_works :: Property 862prop_some1_works = once $ 863 let p = Options.Applicative.NonEmpty.some1 (flag' () (short 'a')) 864 i = info p idm 865 result = run i ["-a", "-a"] 866 in assertResult result $ \xs -> () :| [()] === xs 867 868prop_help_contexts :: Property 869prop_help_contexts = once $ 870 let 871 grabHelpMessage (Failure failure) = 872 let (msg, ExitSuccess) = renderFailure failure "<text>" 873 in msg 874 grabHelpMessage _ = error "Parse did not render help text" 875 876 i = Cabal.pinfo 877 pre = run i ["install", "--help"] 878 post = run i ["--help", "install"] 879 in grabHelpMessage pre === grabHelpMessage post 880 881prop_help_unknown_context :: Property 882prop_help_unknown_context = once $ 883 let 884 grabHelpMessage (Failure failure) = 885 let (msg, ExitSuccess) = renderFailure failure "<text>" 886 in msg 887 grabHelpMessage _ = error "Parse did not render help text" 888 889 i = Cabal.pinfo 890 pre = run i ["--help"] 891 post = run i ["--help", "not-a-command"] 892 in grabHelpMessage pre === grabHelpMessage post 893 894--- 895 896deriving instance Arbitrary a => Arbitrary (Chunk a) 897deriving instance Eq SimpleDoc 898deriving instance Show SimpleDoc 899 900equalDocs :: Float -> Int -> Doc -> Doc -> Property 901equalDocs f w d1 d2 = Doc.renderPretty f w d1 902 === Doc.renderPretty f w d2 903 904prop_listToChunk_1 :: [String] -> Property 905prop_listToChunk_1 xs = isEmpty (listToChunk xs) === null xs 906 907prop_listToChunk_2 :: [String] -> Property 908prop_listToChunk_2 xs = listToChunk xs === mconcat (fmap pure xs) 909 910prop_extractChunk_1 :: String -> Property 911prop_extractChunk_1 x = extractChunk (pure x) === x 912 913prop_extractChunk_2 :: Chunk String -> Property 914prop_extractChunk_2 x = extractChunk (fmap pure x) === x 915 916prop_stringChunk_1 :: Positive Float -> Positive Int -> String -> Property 917prop_stringChunk_1 (Positive f) (Positive w) s = 918 equalDocs f w (extractChunk (stringChunk s)) 919 (Doc.string s) 920 921prop_stringChunk_2 :: String -> Property 922prop_stringChunk_2 s = isEmpty (stringChunk s) === null s 923 924prop_paragraph :: String -> Property 925prop_paragraph s = isEmpty (paragraph s) === null (words s) 926 927--- 928 929-- 930-- From 931-- https://en.wikipedia.org/wiki/Damerau%E2%80%93Levenshtein_distance 932-- 933-- In information theory and computer science, the Damerau–Levenshtein 934-- distance is a distance (string metric) between two strings, i.e., 935-- finite sequence of symbols, given by counting the minimum number 936-- of operations needed to transform one string into the other, where 937-- an operation is defined as an insertion, deletion, or substitution 938-- of a single character, or a transposition of two adjacent characters. 939-- 940prop_edit_distance_gezero :: String -> String -> Bool 941prop_edit_distance_gezero a b = editDistance a b >= 0 942 943prop_edit_insertion :: [Char] -> Char -> [Char] -> Property 944prop_edit_insertion as i bs = 945 editDistance (as ++ bs) (as ++ [i] ++ bs) === 1 946 947prop_edit_symmetric :: [Char] -> [Char] -> Property 948prop_edit_symmetric as bs = 949 editDistance as bs === editDistance bs as 950 951prop_edit_substitution :: [Char] -> [Char] -> Char -> Char -> Property 952prop_edit_substitution as bs a b = a /= b ==> 953 editDistance (as ++ [a] ++ bs) (as ++ [b] ++ bs) === 1 954 955prop_edit_transposition :: [Char] -> [Char] -> Char -> Char -> Property 956prop_edit_transposition as bs a b = a /= b ==> 957 editDistance (as ++ [a,b] ++ bs) (as ++ [b,a] ++ bs) === 1 958 959--- 960 961return [] 962main :: IO () 963main = do 964 result <- $(quickCheckAll) 965 unless result exitFailure 966