From d31bf0233e533c562f404b02ae240c46c1d1760a Mon Sep 17 00:00:00 2001 From: Pagwin Date: Fri, 4 Sep 2026 15:39:36 -0400 Subject: [PATCH] swap hedgehog out for QuickCheck The test suite now runs on tasty + tasty-quickcheck. Translation is mechanical: `property`/`forAll`/`lift` become `monadicIO`/`pick`/`run`, `success`/`fail` become `pure ()`/`stop` with a counterexample, and Hedgehog's ranged generators are replaced by a `linear` helper that scales with QuickCheck's size parameter. Shrinking is dropped since QuickCheck can't shrink these while keeping the generated text within the ranges the assertions assume. The expected-value patterns were also stale relative to the IR (`LI`'s `child` field is gone, blocks carry a trailing `Attrs`, list types carry a `style`), so they've been updated to match. The structural checks are otherwise unchanged. Co-Authored-By: Claude Opus 5 --- .gitignore | 2 + psb.cabal | 2 +- tests/Markdown/Parse.hs | 331 +++++++++++++++++++++------------------- 3 files changed, 180 insertions(+), 155 deletions(-) diff --git a/.gitignore b/.gitignore index 9cf1186..40a4cc1 100644 --- a/.gitignore +++ b/.gitignore @@ -1,2 +1,4 @@ dist-newstyle .shake +.claude +.serena diff --git a/psb.cabal b/psb.cabal index ed96c30..bddd0f2 100644 --- a/psb.cabal +++ b/psb.cabal @@ -36,7 +36,7 @@ test-suite test-markdown-parse hs-source-dirs: tests type: exitcode-stdio-1.0 main-is: Markdown/Parse.hs - build-depends: base, text, megaparsec, transformers, hedgehog, time, psb + build-depends: base, text, megaparsec, transformers, QuickCheck, tasty, tasty-quickcheck, time, psb default-extensions: ApplicativeDo DataKinds NamedFieldPuns DerivingVia LambdaCase TypeApplications DeriveGeneric OverloadedRecordDot NamedFieldPuns DuplicateRecordFields DisambiguateRecordFields FlexibleInstances default-language: Haskell2010 diff --git a/tests/Markdown/Parse.hs b/tests/Markdown/Parse.hs index fdb513e..a600000 100644 --- a/tests/Markdown/Parse.hs +++ b/tests/Markdown/Parse.hs @@ -3,156 +3,178 @@ module Main where import Control.Exception (evaluate) -import Control.Monad.Trans.Class (MonadTrans (lift)) -import Data.Either (isRight) -import Data.Functor.Identity (Identity (Identity)) -import Data.String (IsString) +import Data.Functor.Identity (Identity) import Data.Text (Text) import qualified Data.Text as T -import qualified Data.Text.IO as TIO import Data.Void (Void) -import Debug.Trace (traceShow) -import Hedgehog -import qualified Hedgehog.Gen as Gen -import qualified Hedgehog.Range as Range import IR -import Markdown import qualified Markdown -import System.Exit (exitFailure, exitSuccess) import System.Timeout (timeout) -import Text.Megaparsec +import Test.QuickCheck (Gen, Property, chooseInt, counterexample, elements, sized, vectorOf) +import Test.QuickCheck.Monadic (PropertyM, monadicIO, pick, run, stop) +import Test.Tasty (TestTree, defaultMain, testGroup) +import Test.Tasty.QuickCheck (testProperty) +import Text.Megaparsec (ParseErrorBundle, ParsecT, errorBundlePretty, parse) main :: IO () -main = do - cond <- - checkParallel $ - Group - "Parse Tests" - [ ("all_compile", all_compiles), - ("block_html_compile_edgecase", block_html_compile_edgecase), - ("header_and_paragraph", header_and_paragraph), - ("paragraph_and_header_and_paragraph", paragraph_and_header_and_paragraph), - ("bold_and_header_and_paragraph", bold_and_header_and_paragraph), - ("code_block", code_block), - ("code_block_hanging", code_block_hanging), - ("two_blockquotes", two_blockquotes), - ("unordered_list", unordered_list), - ("header_after_unordered_list", header_after_unordered_list), - ("ordered_list", ordered_list), - ("multiple_ordered_lists", multiple_ordered_lists), - ("header_then_ordered_list", header_then_ordered_list), - ("simple_nested_ordered_list", simple_nested_ordered_list), - ("nested_unordered_list", nested_unordered_list), - ("greedy_plain_text", greedy_plain_text) - -- ("",), - ] - if cond - then exitSuccess - else exitFailure +main = defaultMain tests + +tests :: TestTree +tests = + testGroup + "Parse Tests" + [ testProperty "all_compile" all_compiles, + testProperty "block_html_compile_edgecase" block_html_compile_edgecase, + testProperty "header_and_paragraph" header_and_paragraph, + testProperty "paragraph_and_header_and_paragraph" paragraph_and_header_and_paragraph, + testProperty "bold_and_header_and_paragraph" bold_and_header_and_paragraph, + testProperty "code_block" code_block, + testProperty "code_block_hanging" code_block_hanging, + testProperty "two_blockquotes" two_blockquotes, + testProperty "unordered_list" unordered_list, + testProperty "header_after_unordered_list" header_after_unordered_list, + testProperty "ordered_list" ordered_list, + testProperty "multiple_ordered_lists" multiple_ordered_lists, + testProperty "header_then_ordered_list" header_then_ordered_list, + testProperty "simple_nested_ordered_list" simple_nested_ordered_list, + testProperty "nested_unordered_list" nested_unordered_list, + testProperty "greedy_plain_text" greedy_plain_text + -- testProperty "" , + ] + +-- Hedgehog's Range.linear grows the upper bound with the size of the test +-- case, this is the same thing in terms of QuickCheck's sizing +linear :: Int -> Int -> Gen Int +linear lo hi = sized $ \size -> + let scaled = lo + ((hi - lo) * min size 99) `div` 99 + in chooseInt (lo, max lo scaled) + +textOf :: Gen Char -> Int -> Int -> Gen Text +textOf char_gen lo hi = do + len <- linear lo hi + T.pack <$> vectorOf len char_gen + +ascii :: Gen Char +ascii = elements ['\0' .. '\127'] + +alpha :: Gen Char +alpha = elements (['a' .. 'z'] <> ['A' .. 'Z']) + +alphaNum :: Gen Char +alphaNum = elements (['a' .. 'z'] <> ['A' .. 'Z'] <> ['0' .. '9']) -- timeout of 1 second, all of these tests should be completely clear of that, if they run longer they should fail -generic_parse inp = lift $ timeout 1000000 $ evaluate $ parse (Markdown.document :: ParsecT Void Text Identity IR.Document) "test_input" inp +generic_parse :: Text -> PropertyM IO (Maybe (Either (ParseErrorBundle Text Void) Document)) +generic_parse inp = run $ timeout 1000000 $ evaluate $ parse (Markdown.document :: ParsecT Void Text Identity IR.Document) "test_input" inp + +-- the equivalent of Hedgehog's `success` +succeed :: PropertyM IO () +succeed = pure () + +-- the equivalent of Hedgehog's `fail` +failWith :: String -> PropertyM IO a +failWith message = stop $ counterexample message False all_compiles :: Property -all_compiles = property $ do - xs <- forAll $ Gen.text (Range.linear 0 100) Gen.ascii +all_compiles = monadicIO $ do + xs <- pick $ textOf ascii 0 100 parsed <- generic_parse xs case parsed of - Nothing -> fail $ "Hit Timeout" - (Just (Right _)) -> success - (Just (Left e)) -> fail $ errorBundlePretty e + Nothing -> failWith "Hit Timeout" + (Just (Right _)) -> succeed + (Just (Left e)) -> failWith $ errorBundlePretty e block_html_compile_edgecase :: Property -block_html_compile_edgecase = property $ do - let gen = forAll $ Gen.text (Range.linear 0 10) Gen.alphaNum +block_html_compile_edgecase = monadicIO $ do + let gen = pick $ textOf alphaNum 0 10 tagName <- gen misc1 <- gen misc2 <- gen parsed <- generic_parse $ (T.concat ["<", tagName, ">", misc1, " ", misc2]) case parsed of - Nothing -> fail $ "Hit Timeout" - (Just (Right _)) -> success - (Just (Left e)) -> fail $ errorBundlePretty e + Nothing -> failWith "Hit Timeout" + (Just (Right _)) -> succeed + (Just (Left e)) -> failWith $ errorBundlePretty e header_and_paragraph :: Property -header_and_paragraph = property $ do - header_text <- forAll $ Gen.text (Range.linear 1 10) Gen.alpha - header_level <- forAll $ Gen.int (Range.linear 1 6) - paragraph_text <- forAll $ Gen.text (Range.linear 1 10) Gen.alpha +header_and_paragraph = monadicIO $ do + header_text <- pick $ textOf alpha 1 10 + header_level <- pick $ linear 1 6 + paragraph_text <- pick $ textOf alpha 1 10 let input = (T.pack $ take header_level $ repeat '#') <> header_text <> "\n\n" <> paragraph_text parsed <- generic_parse input case parsed of - Nothing -> fail $ "Hit Timeout" - (Just (Right (Doc [Heading (H {level = header_level, text = [Text (header_text)]}), Paragraph (P ([Text paragraph_text]))]))) -> success - (Just (Right tree)) -> fail $ "Incorrect syntax tree: " <> show tree - (Just (Left e)) -> fail $ errorBundlePretty e + Nothing -> failWith "Hit Timeout" + (Just (Right (Doc [Heading (H {level = header_level, text = [Text (header_text)]}) _, Paragraph (P ([Text paragraph_text])) _]))) -> succeed + (Just (Right tree)) -> failWith $ "Incorrect syntax tree: " <> show tree + (Just (Left e)) -> failWith $ errorBundlePretty e paragraph_and_header_and_paragraph :: Property -paragraph_and_header_and_paragraph = property $ do - paragraph1_text <- forAll $ Gen.text (Range.linear 1 10) Gen.alpha - header_text <- forAll $ Gen.text (Range.linear 1 10) Gen.alpha - header_level <- forAll $ Gen.int (Range.linear 1 6) - paragraph2_text <- forAll $ Gen.text (Range.linear 1 10) Gen.alpha +paragraph_and_header_and_paragraph = monadicIO $ do + paragraph1_text <- pick $ textOf alpha 1 10 + header_text <- pick $ textOf alpha 1 10 + header_level <- pick $ linear 1 6 + paragraph2_text <- pick $ textOf alpha 1 10 let input = paragraph1_text <> "\n\n" <> (T.pack $ take header_level $ repeat '#') <> header_text <> "\n\n" <> paragraph2_text parsed <- generic_parse input case parsed of - Nothing -> fail $ "Hit Timeout" - (Just (Right (Doc [Paragraph (P ([Text paragarph1_text])), Heading (H {level = header_level, text = [Text (header_text)]}), Paragraph (P ([Text paragraph2_text]))]))) -> success - (Just (Right tree)) -> fail $ "Incorrect syntax tree: " <> show tree - (Just (Left e)) -> fail $ errorBundlePretty e + Nothing -> failWith "Hit Timeout" + (Just (Right (Doc [Paragraph (P ([Text paragarph1_text])) _, Heading (H {level = header_level, text = [Text (header_text)]}) _, Paragraph (P ([Text paragraph2_text])) _]))) -> succeed + (Just (Right tree)) -> failWith $ "Incorrect syntax tree: " <> show tree + (Just (Left e)) -> failWith $ errorBundlePretty e bold_and_header_and_paragraph :: Property -bold_and_header_and_paragraph = property $ do - bold_text <- forAll $ Gen.text (Range.linear 1 10) Gen.alpha - header_text <- forAll $ Gen.text (Range.linear 1 10) Gen.alpha - header_level <- forAll $ Gen.int (Range.linear 1 6) - paragraph_text <- forAll $ Gen.text (Range.linear 1 10) Gen.alpha +bold_and_header_and_paragraph = monadicIO $ do + bold_text <- pick $ textOf alpha 1 10 + header_text <- pick $ textOf alpha 1 10 + header_level <- pick $ linear 1 6 + paragraph_text <- pick $ textOf alpha 1 10 let input = "**" <> bold_text <> "**\n\n" <> (T.pack $ take header_level $ repeat '#') <> header_text <> "\n\n" <> paragraph_text parsed <- generic_parse input case parsed of - Nothing -> fail $ "Hit Timeout" - (Just (Right (Doc [Paragraph (P ([Bold [Text bold_text]])), Heading (H {level = header_level, text = [Text (header_text)]}), Paragraph (P ([Text paragraph_text]))]))) -> success - (Just (Right tree)) -> fail $ "Incorrect syntax tree: " <> show tree - (Just (Left e)) -> fail $ errorBundlePretty e + Nothing -> failWith "Hit Timeout" + (Just (Right (Doc [Paragraph (P ([Bold [Text bold_text] _])) _, Heading (H {level = header_level, text = [Text (header_text)]}) _, Paragraph (P ([Text paragraph_text])) _]))) -> succeed + (Just (Right tree)) -> failWith $ "Incorrect syntax tree: " <> show tree + (Just (Left e)) -> failWith $ errorBundlePretty e code_block :: Property -code_block = property $ do - language <- forAll $ Gen.text (Range.linear 1 10) Gen.alpha - code <- forAll $ Gen.text (Range.linear 1 10) Gen.alpha +code_block = monadicIO $ do + language <- pick $ textOf alpha 1 10 + code <- pick $ textOf alpha 1 10 let input = "```" <> language <> "\n" <> code <> "\n```" parsed <- generic_parse input case parsed of - Nothing -> fail $ "Hit Timeout" - (Just (Right (Doc [Code (C {language, code})]))) -> success - (Just (Right tree)) -> fail $ "Incorrect syntax tree: " <> show tree - (Just (Left e)) -> fail $ errorBundlePretty e + Nothing -> failWith "Hit Timeout" + (Just (Right (Doc [Code (C {language, code}) _]))) -> succeed + (Just (Right tree)) -> failWith $ "Incorrect syntax tree: " <> show tree + (Just (Left e)) -> failWith $ errorBundlePretty e code_block_hanging :: Property -code_block_hanging = property $ do - language <- forAll $ Gen.text (Range.linear 1 10) Gen.alpha - code <- forAll $ Gen.text (Range.linear 1 10) Gen.alpha +code_block_hanging = monadicIO $ do + language <- pick $ textOf alpha 1 10 + code <- pick $ textOf alpha 1 10 let input = "```" <> language <> "\n" <> code <> "```" parsed <- generic_parse input case parsed of - Nothing -> fail $ "Hit Timeout" + Nothing -> failWith "Hit Timeout" -- we're just testing for hanging - (Just (Right _)) -> success - (Just (Left e)) -> fail $ errorBundlePretty e + (Just (Right _)) -> succeed + (Just (Left e)) -> failWith $ errorBundlePretty e two_blockquotes :: Property -two_blockquotes = property $ do - let text_gen = forAll $ Gen.text (Range.linear 1 10) Gen.alpha +two_blockquotes = monadicIO $ do + let text_gen = pick $ textOf alpha 1 10 text_1 <- text_gen text_2 <- text_gen let input = "> " <> text_1 <> "\n\n> " <> text_2 @@ -160,14 +182,14 @@ two_blockquotes = property $ do parsed <- generic_parse input case parsed of - Nothing -> fail $ "Hit Timeout" - (Just (Right (Doc [BlockQuote (Q [Text text_1]), BlockQuote (Q [Text text_2])]))) -> success - (Just (Right tree)) -> fail $ "Incorrect syntax tree: " <> show tree - (Just (Left e)) -> fail $ errorBundlePretty e + Nothing -> failWith "Hit Timeout" + (Just (Right (Doc [BlockQuote (Q [Transparent [Text text_1]]) _, BlockQuote (Q [Transparent [Text text_2]]) _]))) -> succeed + (Just (Right tree)) -> failWith $ "Incorrect syntax tree: " <> show tree + (Just (Left e)) -> failWith $ errorBundlePretty e unordered_list :: Property -unordered_list = property $ do - let text_gen = forAll $ Gen.text (Range.linear 1 10) Gen.alpha +unordered_list = monadicIO $ do + let text_gen = pick $ textOf alpha 1 10 text_1 <- text_gen text_2 <- text_gen let input = "- " <> text_1 <> "\n- " <> text_2 @@ -175,31 +197,31 @@ unordered_list = property $ do parsed <- generic_parse input case parsed of - Nothing -> fail $ "Hit Timeout" - (Just (Right (Doc [List (L {list_type = Unordered, items = [LI {content = [Text text_1], child = Nothing}, LI {content = [Text text_2], child = Nothing}]})]))) -> success - (Just (Right tree)) -> fail $ "Incorrect syntax tree: " <> show tree - (Just (Left e)) -> fail $ errorBundlePretty e + Nothing -> failWith "Hit Timeout" + (Just (Right (Doc [List (L {list_type = Unordered {}, items = [LI {content = [Transparent [Text text_1]]}, LI {content = [Transparent [Text text_2]]}]}) _]))) -> succeed + (Just (Right tree)) -> failWith $ "Incorrect syntax tree: " <> show tree + (Just (Left e)) -> failWith $ errorBundlePretty e header_after_unordered_list :: Property -header_after_unordered_list = property $ do - let text_gen = forAll $ Gen.text (Range.linear 1 10) Gen.alpha +header_after_unordered_list = monadicIO $ do + let text_gen = pick $ textOf alpha 1 10 bullet_text <- text_gen header_text <- text_gen - header_level <- forAll $ Gen.int (Range.linear 1 6) + header_level <- pick $ linear 1 6 let input = "- " <> bullet_text <> "\n\n" <> (T.pack $ take header_level $ repeat '#') <> header_text parsed <- generic_parse input case parsed of - Nothing -> fail $ "Hit Timeout" - (Just (Right (Doc [List (L {list_type = Unordered, items = [LI {content = [Text bullet_text], child = Nothing}]}), Heading (H {level = header_level, text = [Text header_text]})]))) -> success - (Just (Right tree)) -> fail $ "Incorrect syntax tree: " <> show tree - (Just (Left e)) -> fail $ errorBundlePretty e + Nothing -> failWith "Hit Timeout" + (Just (Right (Doc [List (L {list_type = Unordered {}, items = [LI {content = [Transparent [Text bullet_text]]}]}) _, Heading (H {level = header_level, text = [Text header_text]}) _]))) -> succeed + (Just (Right tree)) -> failWith $ "Incorrect syntax tree: " <> show tree + (Just (Left e)) -> failWith $ errorBundlePretty e ordered_list :: Property -ordered_list = property $ do - let text_gen = forAll $ Gen.text (Range.linear 1 10) Gen.alpha +ordered_list = monadicIO $ do + let text_gen = pick $ textOf alpha 1 10 item_1 <- text_gen item_2 <- text_gen item_3 <- text_gen @@ -208,14 +230,14 @@ ordered_list = property $ do parsed <- generic_parse input case parsed of - Nothing -> fail $ "Hit Timeout" - (Just (Right (Doc [List (L {list_type = Ordered, items = [LI {content = [Text item_1], child = Nothing}, LI {content = [Text item_2], child = Nothing}, LI {content = [Text item_3], child = Nothing}]})]))) -> success - (Just (Right tree)) -> fail $ "Incorrect syntax tree: " <> show tree - (Just (Left e)) -> fail $ errorBundlePretty e + Nothing -> failWith "Hit Timeout" + (Just (Right (Doc [List (L {list_type = Ordered {}, items = [LI {content = [Transparent [Text item_1]]}, LI {content = [Transparent [Text item_2]]}, LI {content = [Transparent [Text item_3]]}]}) _]))) -> succeed + (Just (Right tree)) -> failWith $ "Incorrect syntax tree: " <> show tree + (Just (Left e)) -> failWith $ errorBundlePretty e multiple_ordered_lists :: Property -multiple_ordered_lists = property $ do - let text_gen = forAll $ Gen.text (Range.linear 1 10) Gen.alpha +multiple_ordered_lists = monadicIO $ do + let text_gen = pick $ textOf alpha 1 10 item_1 <- text_gen item_2 <- text_gen item_3 <- text_gen @@ -223,47 +245,47 @@ multiple_ordered_lists = property $ do parsed <- generic_parse input case parsed of - Nothing -> fail $ "Hit Timeout" + Nothing -> failWith "Hit Timeout" ( Just ( Right ( Doc - [ List (L {list_type = Ordered, items = [LI {content = [Text item_1], child = Nothing}]}), - List (L {list_type = Ordered, items = [LI {content = [Text item_2], child = Nothing}]}), - List (L {list_type = Ordered, items = [LI {content = [Text item_3], child = Nothing}]}) + [ List (L {list_type = Ordered {}, items = [LI {content = [Transparent [Text item_1]]}]}) _, + List (L {list_type = Ordered {}, items = [LI {content = [Transparent [Text item_2]]}]}) _, + List (L {list_type = Ordered {}, items = [LI {content = [Transparent [Text item_3]]}]}) _ ] ) ) - ) -> success - (Just (Right tree)) -> fail $ "Incorrect syntax tree: " <> show tree - (Just (Left e)) -> fail $ errorBundlePretty e + ) -> succeed + (Just (Right tree)) -> failWith $ "Incorrect syntax tree: " <> show tree + (Just (Left e)) -> failWith $ errorBundlePretty e simple_nested_ordered_list :: Property -simple_nested_ordered_list = property $ do - let text_gen = forAll $ Gen.text (Range.linear 1 10) Gen.alpha +simple_nested_ordered_list = monadicIO $ do + let text_gen = pick $ textOf alpha 1 10 item_1 <- text_gen item_2 <- text_gen let input = "1) " <> item_1 <> "\n 1) " <> item_2 parsed <- generic_parse input case parsed of - Nothing -> fail $ "Hit Timeout" + Nothing -> failWith "Hit Timeout" ( Just ( Right ( Doc - [ List (L {list_type = Ordered, items = [LI {content = [Text item_1], child = Just (L {list_type = Ordered, items = [LI {content = [Text item_2], child = Nothing}]})}]}) + [ List (L {list_type = Ordered {}, items = [LI {content = [Transparent [Text item_1], List (L {list_type = Ordered {}, items = [LI {content = [Transparent [Text item_2]]}]}) _]}]}) _ ] ) ) - ) -> success - (Just (Right tree)) -> fail $ "Incorrect syntax tree: " <> show tree - (Just (Left e)) -> fail $ errorBundlePretty e + ) -> succeed + (Just (Right tree)) -> failWith $ "Incorrect syntax tree: " <> show tree + (Just (Left e)) -> failWith $ errorBundlePretty e -- - a -- - a -- - b nested_unordered_list :: Property -nested_unordered_list = property $ do - let text_gen = forAll $ Gen.text (Range.linear 1 10) Gen.alpha +nested_unordered_list = monadicIO $ do + let text_gen = pick $ textOf alpha 1 10 item_1 <- text_gen item_2 <- text_gen item_3 <- text_gen @@ -271,27 +293,27 @@ nested_unordered_list = property $ do parsed <- generic_parse input case parsed of - Nothing -> fail $ "Hit Timeout" + Nothing -> failWith "Hit Timeout" ( Just ( Right ( Doc - [ List (L {list_type = Unordered, items = [LI {content = [Text item_1], child = Just (L {list_type = Unordered, items = [LI {content = [Text item_2], child = Nothing}]})}, LI {content = [Text item_3], child = Nothing}]}) + [ List (L {list_type = Unordered {}, items = [LI {content = [Transparent [Text item_1], List (L {list_type = Unordered {}, items = [LI {content = [Transparent [Text item_2]]}]}) _]}, LI {content = [Transparent [Text item_3]]}]}) _ ] ) ) - ) -> success - (Just (Right tree)) -> fail $ "Incorrect syntax tree: " <> show tree - (Just (Left e)) -> fail $ errorBundlePretty e + ) -> succeed + (Just (Right tree)) -> failWith $ "Incorrect syntax tree: " <> show tree + (Just (Left e)) -> failWith $ errorBundlePretty e -- ## -- 1) -- 2) -- 3) header_then_ordered_list :: Property -header_then_ordered_list = property $ do - let text_gen = forAll $ Gen.text (Range.linear 1 10) Gen.alpha +header_then_ordered_list = monadicIO $ do + let text_gen = pick $ textOf alpha 1 10 header <- text_gen - header_level <- forAll $ Gen.int (Range.linear 1 6) + header_level <- pick $ linear 1 6 item_1 <- text_gen item_2 <- text_gen item_3 <- text_gen @@ -300,31 +322,32 @@ header_then_ordered_list = property $ do parsed <- generic_parse input case parsed of - Nothing -> fail $ "Hit Timeout" + Nothing -> failWith "Hit Timeout" ( Just ( Right ( Doc - [ Heading (H {level = header_level, text = header}), + [ Heading (H {level = header_level, text = header}) _, List ( L - { list_type = Ordered, + { list_type = Ordered {}, items = - [ LI {content = [Text item_1], child = Nothing}, - LI {content = [Text item_2], child = Nothing}, - LI {content = [Text item_3], child = Nothing} + [ LI {content = [Transparent [Text item_1]]}, + LI {content = [Transparent [Text item_2]]}, + LI {content = [Transparent [Text item_3]]} ] } ) + _ ] ) ) - ) -> success - (Just (Right tree)) -> fail $ "Incorrect syntax tree: " <> show tree - (Just (Left e)) -> fail $ errorBundlePretty e + ) -> succeed + (Just (Right tree)) -> failWith $ "Incorrect syntax tree: " <> show tree + (Just (Left e)) -> failWith $ errorBundlePretty e greedy_plain_text :: Property -greedy_plain_text = property $ do - let text_gen = forAll $ Gen.text (Range.linear 1 10) Gen.alphaNum +greedy_plain_text = monadicIO $ do + let text_gen = pick $ textOf alphaNum 1 10 pretext <- text_gen shown <- text_gen link <- text_gen @@ -332,7 +355,7 @@ greedy_plain_text = property $ do parsed <- generic_parse $ T.concat [pretext, "[", shown, "]", "(", link, ")"] case parsed of - Nothing -> fail $ "Hit Timeout" - (Just (Right (Doc [Paragraph (P [Text (pretext), Link {linkText = [Text shown], url = link, title = Nothing}])]))) -> success - (Just (Right tree)) -> fail $ "Incorrect syntax tree: " <> show tree - (Just (Left e)) -> fail $ errorBundlePretty e + Nothing -> failWith "Hit Timeout" + (Just (Right (Doc [Paragraph (P [Text (pretext), Link {linkText = [Text shown], url = link, title = Nothing}]) _]))) -> succeed + (Just (Right tree)) -> failWith $ "Incorrect syntax tree: " <> show tree + (Just (Left e)) -> failWith $ errorBundlePretty e