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