Pagwin/psb
1
0
Fork 0
Code Issues 4 Pull requests Projects Releases Packages Wiki Activity

swap hedgehog out for QuickCheck

Browse source 
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 <noreply@anthropic.com>
This commit is contained in:
Pagwin 2026-09-04 15:39:36 -04:00
parent 7a0032c7d3
commit d31bf0233e
No known key found for this signature in database
GPG key ID: 81137023740CA260
3 changed files with 180 additions and 155 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
.gitignore vendored
View file

@ -1,2 +1,4 @@
dist-newstyle dist-newstyle
.shake .shake
.claude
.serena

2
psb.cabal
View file

@ -36,7 +36,7 @@ test-suite test-markdown-parse
hs-source-dirs: tests hs-source-dirs: tests
type: exitcode-stdio-1.0 type: exitcode-stdio-1.0
main-is: Markdown/Parse.hs 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-extensions: ApplicativeDo DataKinds NamedFieldPuns DerivingVia LambdaCase TypeApplications DeriveGeneric OverloadedRecordDot NamedFieldPuns DuplicateRecordFields DisambiguateRecordFields FlexibleInstances
default-language: Haskell2010 default-language: Haskell2010

327
tests/Markdown/Parse.hs
View file

@ -3,156 +3,178 @@
module Main where module Main where
import Control.Exception (evaluate) import Control.Exception (evaluate)
import Control.Monad.Trans.Class (MonadTrans (lift)) import Data.Functor.Identity (Identity)
import Data.Either (isRight)
import Data.Functor.Identity (Identity (Identity))
import Data.String (IsString)
import Data.Text (Text) import Data.Text (Text)
import qualified Data.Text as T import qualified Data.Text as T
import qualified Data.Text.IO as TIO
import Data.Void (Void) 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 IR
import Markdown
import qualified Markdown import qualified Markdown
import System.Exit (exitFailure, exitSuccess)
import System.Timeout (timeout) 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 :: IO ()
main = do main = defaultMain tests
cond <-
checkParallel $ tests :: TestTree
Group tests =
testGroup
"Parse Tests" "Parse Tests"
[ ("all_compile", all_compiles), [ testProperty "all_compile" all_compiles,
("block_html_compile_edgecase", block_html_compile_edgecase), testProperty "block_html_compile_edgecase" block_html_compile_edgecase,
("header_and_paragraph", header_and_paragraph), testProperty "header_and_paragraph" header_and_paragraph,
("paragraph_and_header_and_paragraph", paragraph_and_header_and_paragraph), testProperty "paragraph_and_header_and_paragraph" paragraph_and_header_and_paragraph,
("bold_and_header_and_paragraph", bold_and_header_and_paragraph), testProperty "bold_and_header_and_paragraph" bold_and_header_and_paragraph,
("code_block", code_block), testProperty "code_block" code_block,
("code_block_hanging", code_block_hanging), testProperty "code_block_hanging" code_block_hanging,
("two_blockquotes", two_blockquotes), testProperty "two_blockquotes" two_blockquotes,
("unordered_list", unordered_list), testProperty "unordered_list" unordered_list,
("header_after_unordered_list", header_after_unordered_list), testProperty "header_after_unordered_list" header_after_unordered_list,
("ordered_list", ordered_list), testProperty "ordered_list" ordered_list,
("multiple_ordered_lists", multiple_ordered_lists), testProperty "multiple_ordered_lists" multiple_ordered_lists,
("header_then_ordered_list", header_then_ordered_list), testProperty "header_then_ordered_list" header_then_ordered_list,
("simple_nested_ordered_list", simple_nested_ordered_list), testProperty "simple_nested_ordered_list" simple_nested_ordered_list,
("nested_unordered_list", nested_unordered_list), testProperty "nested_unordered_list" nested_unordered_list,
("greedy_plain_text", greedy_plain_text) testProperty "greedy_plain_text" greedy_plain_text
-- ("",), -- testProperty "" ,
] ]
if cond
then exitSuccess -- Hedgehog's Range.linear grows the upper bound with the size of the test
else exitFailure -- 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 -- 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
all_compiles = property $ do all_compiles = monadicIO $ do
xs <- forAll $ Gen.text (Range.linear 0 100) Gen.ascii xs <- pick $ textOf ascii 0 100
parsed <- generic_parse xs parsed <- generic_parse xs
case parsed of case parsed of
Nothing -> fail $ "Hit Timeout" Nothing -> failWith "Hit Timeout"
(Just (Right _)) -> success (Just (Right _)) -> succeed
(Just (Left e)) -> fail $ errorBundlePretty e (Just (Left e)) -> failWith $ errorBundlePretty e
block_html_compile_edgecase :: Property block_html_compile_edgecase :: Property
block_html_compile_edgecase = property $ do block_html_compile_edgecase = monadicIO $ do
let gen = forAll $ Gen.text (Range.linear 0 10) Gen.alphaNum let gen = pick $ textOf alphaNum 0 10
tagName <- gen tagName <- gen
misc1 <- gen misc1 <- gen
misc2 <- gen misc2 <- gen
parsed <- generic_parse $ (T.concat ["<", tagName, ">", misc1, "</", tagName, "> ", misc2]) parsed <- generic_parse $ (T.concat ["<", tagName, ">", misc1, "</", tagName, "> ", misc2])
case parsed of case parsed of
Nothing -> fail $ "Hit Timeout" Nothing -> failWith "Hit Timeout"
(Just (Right _)) -> success (Just (Right _)) -> succeed
(Just (Left e)) -> fail $ errorBundlePretty e (Just (Left e)) -> failWith $ errorBundlePretty e
header_and_paragraph :: Property header_and_paragraph :: Property
header_and_paragraph = property $ do header_and_paragraph = monadicIO $ do
header_text <- forAll $ Gen.text (Range.linear 1 10) Gen.alpha header_text <- pick $ textOf alpha 1 10
header_level <- forAll $ Gen.int (Range.linear 1 6) header_level <- pick $ linear 1 6
paragraph_text <- forAll $ Gen.text (Range.linear 1 10) Gen.alpha paragraph_text <- pick $ textOf alpha 1 10
let input = (T.pack $ take header_level $ repeat '#') <> header_text <> "\n\n" <> paragraph_text let input = (T.pack $ take header_level $ repeat '#') <> header_text <> "\n\n" <> paragraph_text
parsed <- generic_parse input parsed <- generic_parse input
case parsed of case parsed of
Nothing -> fail $ "Hit Timeout" Nothing -> failWith "Hit Timeout"
(Just (Right (Doc [Heading (H {level = header_level, text = [Text (header_text)]}), Paragraph (P ([Text paragraph_text]))]))) -> success (Just (Right (Doc [Heading (H {level = header_level, text = [Text (header_text)]}) _, Paragraph (P ([Text paragraph_text])) _]))) -> succeed
(Just (Right tree)) -> fail $ "Incorrect syntax tree: " <> show tree (Just (Right tree)) -> failWith $ "Incorrect syntax tree: " <> show tree
(Just (Left e)) -> fail $ errorBundlePretty e (Just (Left e)) -> failWith $ errorBundlePretty e
paragraph_and_header_and_paragraph :: Property paragraph_and_header_and_paragraph :: Property
paragraph_and_header_and_paragraph = property $ do paragraph_and_header_and_paragraph = monadicIO $ do
paragraph1_text <- forAll $ Gen.text (Range.linear 1 10) Gen.alpha paragraph1_text <- pick $ textOf alpha 1 10
header_text <- forAll $ Gen.text (Range.linear 1 10) Gen.alpha header_text <- pick $ textOf alpha 1 10
header_level <- forAll $ Gen.int (Range.linear 1 6) header_level <- pick $ linear 1 6
paragraph2_text <- forAll $ Gen.text (Range.linear 1 10) Gen.alpha 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 let input = paragraph1_text <> "\n\n" <> (T.pack $ take header_level $ repeat '#') <> header_text <> "\n\n" <> paragraph2_text
parsed <- generic_parse input parsed <- generic_parse input
case parsed of case parsed of
Nothing -> fail $ "Hit Timeout" 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]))]))) -> success (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)) -> fail $ "Incorrect syntax tree: " <> show tree (Just (Right tree)) -> failWith $ "Incorrect syntax tree: " <> show tree
(Just (Left e)) -> fail $ errorBundlePretty e (Just (Left e)) -> failWith $ errorBundlePretty e
bold_and_header_and_paragraph :: Property bold_and_header_and_paragraph :: Property
bold_and_header_and_paragraph = property $ do bold_and_header_and_paragraph = monadicIO $ do
bold_text <- forAll $ Gen.text (Range.linear 1 10) Gen.alpha bold_text <- pick $ textOf alpha 1 10
header_text <- forAll $ Gen.text (Range.linear 1 10) Gen.alpha header_text <- pick $ textOf alpha 1 10
header_level <- forAll $ Gen.int (Range.linear 1 6) header_level <- pick $ linear 1 6
paragraph_text <- forAll $ Gen.text (Range.linear 1 10) Gen.alpha 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 let input = "**" <> bold_text <> "**\n\n" <> (T.pack $ take header_level $ repeat '#') <> header_text <> "\n\n" <> paragraph_text
parsed <- generic_parse input parsed <- generic_parse input
case parsed of case parsed of
Nothing -> fail $ "Hit Timeout" 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]))]))) -> success (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)) -> fail $ "Incorrect syntax tree: " <> show tree (Just (Right tree)) -> failWith $ "Incorrect syntax tree: " <> show tree
(Just (Left e)) -> fail $ errorBundlePretty e (Just (Left e)) -> failWith $ errorBundlePretty e
code_block :: Property code_block :: Property
code_block = property $ do code_block = monadicIO $ do
language <- forAll $ Gen.text (Range.linear 1 10) Gen.alpha language <- pick $ textOf alpha 1 10
code <- forAll $ Gen.text (Range.linear 1 10) Gen.alpha code <- pick $ textOf alpha 1 10
let input = "```" <> language <> "\n" <> code <> "\n```" let input = "```" <> language <> "\n" <> code <> "\n```"
parsed <- generic_parse input parsed <- generic_parse input
case parsed of case parsed of
Nothing -> fail $ "Hit Timeout" Nothing -> failWith "Hit Timeout"
(Just (Right (Doc [Code (C {language, code})]))) -> success (Just (Right (Doc [Code (C {language, code}) _]))) -> succeed
(Just (Right tree)) -> fail $ "Incorrect syntax tree: " <> show tree (Just (Right tree)) -> failWith $ "Incorrect syntax tree: " <> show tree
(Just (Left e)) -> fail $ errorBundlePretty e (Just (Left e)) -> failWith $ errorBundlePretty e
code_block_hanging :: Property code_block_hanging :: Property
code_block_hanging = property $ do code_block_hanging = monadicIO $ do
language <- forAll $ Gen.text (Range.linear 1 10) Gen.alpha language <- pick $ textOf alpha 1 10
code <- forAll $ Gen.text (Range.linear 1 10) Gen.alpha code <- pick $ textOf alpha 1 10
let input = "```" <> language <> "\n" <> code <> "```" let input = "```" <> language <> "\n" <> code <> "```"
parsed <- generic_parse input parsed <- generic_parse input
case parsed of case parsed of
Nothing -> fail $ "Hit Timeout" Nothing -> failWith "Hit Timeout"
-- we're just testing for hanging -- we're just testing for hanging
(Just (Right _)) -> success (Just (Right _)) -> succeed
(Just (Left e)) -> fail $ errorBundlePretty e (Just (Left e)) -> failWith $ errorBundlePretty e
two_blockquotes :: Property two_blockquotes :: Property
two_blockquotes = property $ do two_blockquotes = monadicIO $ do
let text_gen = forAll $ Gen.text (Range.linear 1 10) Gen.alpha let text_gen = pick $ textOf alpha 1 10
text_1 <- text_gen text_1 <- text_gen
text_2 <- text_gen text_2 <- text_gen
let input = "> " <> text_1 <> "\n\n> " <> text_2 let input = "> " <> text_1 <> "\n\n> " <> text_2
@ -160,14 +182,14 @@ two_blockquotes = property $ do
parsed <- generic_parse input parsed <- generic_parse input
case parsed of case parsed of
Nothing -> fail $ "Hit Timeout" Nothing -> failWith "Hit Timeout"
(Just (Right (Doc [BlockQuote (Q [Text text_1]), BlockQuote (Q [Text text_2])]))) -> success (Just (Right (Doc [BlockQuote (Q [Transparent [Text text_1]]) _, BlockQuote (Q [Transparent [Text text_2]]) _]))) -> succeed
(Just (Right tree)) -> fail $ "Incorrect syntax tree: " <> show tree (Just (Right tree)) -> failWith $ "Incorrect syntax tree: " <> show tree
(Just (Left e)) -> fail $ errorBundlePretty e (Just (Left e)) -> failWith $ errorBundlePretty e
unordered_list :: Property unordered_list :: Property
unordered_list = property $ do unordered_list = monadicIO $ do
let text_gen = forAll $ Gen.text (Range.linear 1 10) Gen.alpha let text_gen = pick $ textOf alpha 1 10
text_1 <- text_gen text_1 <- text_gen
text_2 <- text_gen text_2 <- text_gen
let input = "- " <> text_1 <> "\n- " <> text_2 let input = "- " <> text_1 <> "\n- " <> text_2
@ -175,31 +197,31 @@ unordered_list = property $ do
parsed <- generic_parse input parsed <- generic_parse input
case parsed of case parsed of
Nothing -> fail $ "Hit Timeout" Nothing -> failWith "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 (Doc [List (L {list_type = Unordered {}, items = [LI {content = [Transparent [Text text_1]]}, LI {content = [Transparent [Text text_2]]}]}) _]))) -> succeed
(Just (Right tree)) -> fail $ "Incorrect syntax tree: " <> show tree (Just (Right tree)) -> failWith $ "Incorrect syntax tree: " <> show tree
(Just (Left e)) -> fail $ errorBundlePretty e (Just (Left e)) -> failWith $ errorBundlePretty e
header_after_unordered_list :: Property header_after_unordered_list :: Property
header_after_unordered_list = property $ do header_after_unordered_list = monadicIO $ do
let text_gen = forAll $ Gen.text (Range.linear 1 10) Gen.alpha let text_gen = pick $ textOf alpha 1 10
bullet_text <- text_gen bullet_text <- text_gen
header_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 let input = "- " <> bullet_text <> "\n\n" <> (T.pack $ take header_level $ repeat '#') <> header_text
parsed <- generic_parse input parsed <- generic_parse input
case parsed of case parsed of
Nothing -> fail $ "Hit Timeout" Nothing -> failWith "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 (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)) -> fail $ "Incorrect syntax tree: " <> show tree (Just (Right tree)) -> failWith $ "Incorrect syntax tree: " <> show tree
(Just (Left e)) -> fail $ errorBundlePretty e (Just (Left e)) -> failWith $ errorBundlePretty e
ordered_list :: Property ordered_list :: Property
ordered_list = property $ do ordered_list = monadicIO $ do
let text_gen = forAll $ Gen.text (Range.linear 1 10) Gen.alpha let text_gen = pick $ textOf alpha 1 10
item_1 <- text_gen item_1 <- text_gen
item_2 <- text_gen item_2 <- text_gen
item_3 <- text_gen item_3 <- text_gen
@ -208,14 +230,14 @@ ordered_list = property $ do
parsed <- generic_parse input parsed <- generic_parse input
case parsed of 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}, LI {content = [Text item_2], child = Nothing}, LI {content = [Text item_3], child = Nothing}]})]))) -> success (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)) -> fail $ "Incorrect syntax tree: " <> show tree (Just (Right tree)) -> failWith $ "Incorrect syntax tree: " <> show tree
(Just (Left e)) -> fail $ errorBundlePretty e (Just (Left e)) -> failWith $ errorBundlePretty e
multiple_ordered_lists :: Property multiple_ordered_lists :: Property
multiple_ordered_lists = property $ do multiple_ordered_lists = monadicIO $ do
let text_gen = forAll $ Gen.text (Range.linear 1 10) Gen.alpha let text_gen = pick $ textOf alpha 1 10
item_1 <- text_gen item_1 <- text_gen
item_2 <- text_gen item_2 <- text_gen
item_3 <- text_gen item_3 <- text_gen
@ -223,47 +245,47 @@ multiple_ordered_lists = property $ do
parsed <- generic_parse input parsed <- generic_parse input
case parsed of case parsed of
Nothing -> fail $ "Hit Timeout" Nothing -> failWith "Hit Timeout"
( Just ( Just
( Right ( Right
( Doc ( Doc
[ List (L {list_type = Ordered, items = [LI {content = [Text item_1], child = Nothing}]}), [ List (L {list_type = Ordered {}, items = [LI {content = [Transparent [Text item_1]]}]}) _,
List (L {list_type = Ordered, items = [LI {content = [Text item_2], child = Nothing}]}), List (L {list_type = Ordered {}, items = [LI {content = [Transparent [Text item_2]]}]}) _,
List (L {list_type = Ordered, items = [LI {content = [Text item_3], child = Nothing}]}) List (L {list_type = Ordered {}, items = [LI {content = [Transparent [Text item_3]]}]}) _
] ]
) )
) )
) -> success ) -> succeed
(Just (Right tree)) -> fail $ "Incorrect syntax tree: " <> show tree (Just (Right tree)) -> failWith $ "Incorrect syntax tree: " <> show tree
(Just (Left e)) -> fail $ errorBundlePretty e (Just (Left e)) -> failWith $ errorBundlePretty e
simple_nested_ordered_list :: Property simple_nested_ordered_list :: Property
simple_nested_ordered_list = property $ do simple_nested_ordered_list = monadicIO $ do
let text_gen = forAll $ Gen.text (Range.linear 1 10) Gen.alpha let text_gen = pick $ textOf alpha 1 10
item_1 <- text_gen item_1 <- text_gen
item_2 <- text_gen item_2 <- text_gen
let input = "1) " <> item_1 <> "\n 1) " <> item_2 let input = "1) " <> item_1 <> "\n 1) " <> item_2
parsed <- generic_parse input parsed <- generic_parse input
case parsed of case parsed of
Nothing -> fail $ "Hit Timeout" Nothing -> failWith "Hit Timeout"
( Just ( Just
( Right ( Right
( Doc ( 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 ) -> succeed
(Just (Right tree)) -> fail $ "Incorrect syntax tree: " <> show tree (Just (Right tree)) -> failWith $ "Incorrect syntax tree: " <> show tree
(Just (Left e)) -> fail $ errorBundlePretty e (Just (Left e)) -> failWith $ errorBundlePretty e
-- - a -- - a
-- - a -- - a
-- - b -- - b
nested_unordered_list :: Property nested_unordered_list :: Property
nested_unordered_list = property $ do nested_unordered_list = monadicIO $ do
let text_gen = forAll $ Gen.text (Range.linear 1 10) Gen.alpha let text_gen = pick $ textOf alpha 1 10
item_1 <- text_gen item_1 <- text_gen
item_2 <- text_gen item_2 <- text_gen
item_3 <- text_gen item_3 <- text_gen
@ -271,27 +293,27 @@ nested_unordered_list = property $ do
parsed <- generic_parse input parsed <- generic_parse input
case parsed of case parsed of
Nothing -> fail $ "Hit Timeout" Nothing -> failWith "Hit Timeout"
( Just ( Just
( Right ( Right
( Doc ( 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 ) -> succeed
(Just (Right tree)) -> fail $ "Incorrect syntax tree: " <> show tree (Just (Right tree)) -> failWith $ "Incorrect syntax tree: " <> show tree
(Just (Left e)) -> fail $ errorBundlePretty e (Just (Left e)) -> failWith $ errorBundlePretty e
-- ## -- ##
-- 1) -- 1)
-- 2) -- 2)
-- 3) -- 3)
header_then_ordered_list :: Property header_then_ordered_list :: Property
header_then_ordered_list = property $ do header_then_ordered_list = monadicIO $ do
let text_gen = forAll $ Gen.text (Range.linear 1 10) Gen.alpha let text_gen = pick $ textOf alpha 1 10
header <- text_gen header <- text_gen
header_level <- forAll $ Gen.int (Range.linear 1 6) header_level <- pick $ linear 1 6
item_1 <- text_gen item_1 <- text_gen
item_2 <- text_gen item_2 <- text_gen
item_3 <- text_gen item_3 <- text_gen
@ -300,31 +322,32 @@ header_then_ordered_list = property $ do
parsed <- generic_parse input parsed <- generic_parse input
case parsed of case parsed of
Nothing -> fail $ "Hit Timeout" Nothing -> failWith "Hit Timeout"
( Just ( Just
( Right ( Right
( Doc ( Doc
[ Heading (H {level = header_level, text = header}), [ Heading (H {level = header_level, text = header}) _,
List List
( L ( L
{ list_type = Ordered, { list_type = Ordered {},
items = items =
[ LI {content = [Text item_1], child = Nothing}, [ LI {content = [Transparent [Text item_1]]},
LI {content = [Text item_2], child = Nothing}, LI {content = [Transparent [Text item_2]]},
LI {content = [Text item_3], child = Nothing} LI {content = [Transparent [Text item_3]]}
] ]
} }
) )
_
] ]
) )
) )
) -> success ) -> succeed
(Just (Right tree)) -> fail $ "Incorrect syntax tree: " <> show tree (Just (Right tree)) -> failWith $ "Incorrect syntax tree: " <> show tree
(Just (Left e)) -> fail $ errorBundlePretty e (Just (Left e)) -> failWith $ errorBundlePretty e
greedy_plain_text :: Property greedy_plain_text :: Property
greedy_plain_text = property $ do greedy_plain_text = monadicIO $ do
let text_gen = forAll $ Gen.text (Range.linear 1 10) Gen.alphaNum let text_gen = pick $ textOf alphaNum 1 10
pretext <- text_gen pretext <- text_gen
shown <- text_gen shown <- text_gen
link <- text_gen link <- text_gen
@ -332,7 +355,7 @@ greedy_plain_text = property $ do
parsed <- generic_parse $ T.concat [pretext, "[", shown, "]", "(", link, ")"] parsed <- generic_parse $ T.concat [pretext, "[", shown, "]", "(", link, ")"]
case parsed of case parsed of
Nothing -> fail $ "Hit Timeout" Nothing -> failWith "Hit Timeout"
(Just (Right (Doc [Paragraph (P [Text (pretext), Link {linkText = [Text shown], url = link, title = Nothing}])]))) -> success (Just (Right (Doc [Paragraph (P [Text (pretext), Link {linkText = [Text shown], url = link, title = Nothing}]) _]))) -> succeed
(Just (Right tree)) -> fail $ "Incorrect syntax tree: " <> show tree (Just (Right tree)) -> failWith $ "Incorrect syntax tree: " <> show tree
(Just (Left e)) -> fail $ errorBundlePretty e (Just (Left e)) -> failWith $ errorBundlePretty e