628f01217e
The suite is now one tasty binary over shared modules, so the Djot
tests can sit next to the Markdown ones without another copy of the
harness:
tests/Main.hs the TestTree
tests/Test/Harness.hs running a parser inside a property
tests/Test/Gen.hs generators, shrinkers, escaping
tests/Test/Gen/Document.hs whole document generation
tests/Markdown/Parse.hs the Markdown properties
Generated values moved from `pick` to `Arbitrary` instances on
newtypes. `pick` embeds its value with `forAll (return a)` and cannot
shrink; going through Arbitrary gets shrinking back at the cost of
hand written shrinkers, which have to preserve the invariants their
generator established.
IR now derives Eq, and the properties assert against a complete
expected tree rather than pattern matching. The old patterns bound
fresh names that shadowed the generated ones, so they only ever
checked the shape of the tree and never its content.
Test.Gen.Document generates a description of a document which renders
to source and derives its own expected tree, so the two stay in step
while shrinking. Rendering goes through a Syntax record so Djot can
reuse the spec and the expectations. Escaping is a generator level
concern: an Escaper says which characters are special and how (or
whether) they can be written literally.
Two properties fail, both on parser bugs rather than test bugs:
code_block fencedCodeBlock inverts its language test, so a
fence naming a language reports Nothing. Djot.hs
gets this right at src/Djot.hs:354.
document_round_trip a nested list with more than one item makes the
whole list fail to parse and fall back to a
paragraph. In listBlock's child parser the second
alternative has no `try`, so it fails having
consumed the first item's indentation. The
existing nesting tests only ever used one nested
item.
Co-Authored-By: Claude Opus 5 <noreply@anthropic.com>
229 lines
9.4 KiB
Haskell
229 lines
9.4 KiB
Haskell
{-# LANGUAGE OverloadedStrings #-}
|
|
|
|
module Markdown.Parse (tests) where
|
|
|
|
import qualified Data.Text as T
|
|
import IR
|
|
import Test.Gen (AlphaNumText (..), AlphaText (..), AsciiText (..), EscapedText (..), HeaderLevel (..), MarkdownText (..))
|
|
import Test.Gen.Document (DocSpec, expected, markdownSyntax, render)
|
|
import Test.Harness (markdownDocument, shouldParse, shouldParseTo)
|
|
import Test.QuickCheck (Property, counterexample)
|
|
import Test.QuickCheck.Monadic (monadicIO)
|
|
import Test.Tasty (TestTree, testGroup)
|
|
import Test.Tasty.QuickCheck (testProperty)
|
|
|
|
tests :: TestTree
|
|
tests =
|
|
testGroup
|
|
"Markdown"
|
|
[ 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 "plain_text_is_literal" plain_text_is_literal,
|
|
testProperty "document_round_trip" document_round_trip
|
|
]
|
|
|
|
hashes :: Int -> T.Text
|
|
hashes level = T.replicate level "#"
|
|
|
|
all_compiles :: AsciiText -> Property
|
|
all_compiles (AsciiText input) = monadicIO $ shouldParse markdownDocument input
|
|
|
|
block_html_compile_edgecase :: AlphaNumText -> AlphaNumText -> AlphaNumText -> Property
|
|
block_html_compile_edgecase (AlphaNumText tag_name) (AlphaNumText misc1) (AlphaNumText misc2) =
|
|
monadicIO $ shouldParse markdownDocument input
|
|
where
|
|
input = T.concat ["<", tag_name, ">", misc1, "</", tag_name, "> ", misc2]
|
|
|
|
header_and_paragraph :: AlphaText -> HeaderLevel -> AlphaText -> Property
|
|
header_and_paragraph (AlphaText header_text) (HeaderLevel level) (AlphaText paragraph_text) =
|
|
monadicIO $ shouldParseTo markdownDocument input tree
|
|
where
|
|
input = hashes level <> header_text <> "\n\n" <> paragraph_text
|
|
tree =
|
|
Doc
|
|
[ Heading (H {level, text = [Text header_text]}) mempty,
|
|
Paragraph (P [Text paragraph_text]) mempty
|
|
]
|
|
|
|
paragraph_and_header_and_paragraph :: AlphaText -> AlphaText -> HeaderLevel -> AlphaText -> Property
|
|
paragraph_and_header_and_paragraph (AlphaText paragraph1_text) (AlphaText header_text) (HeaderLevel level) (AlphaText paragraph2_text) =
|
|
monadicIO $ shouldParseTo markdownDocument input tree
|
|
where
|
|
input = paragraph1_text <> "\n\n" <> hashes level <> header_text <> "\n\n" <> paragraph2_text
|
|
tree =
|
|
Doc
|
|
[ Paragraph (P [Text paragraph1_text]) mempty,
|
|
Heading (H {level, text = [Text header_text]}) mempty,
|
|
Paragraph (P [Text paragraph2_text]) mempty
|
|
]
|
|
|
|
bold_and_header_and_paragraph :: AlphaText -> AlphaText -> HeaderLevel -> AlphaText -> Property
|
|
bold_and_header_and_paragraph (AlphaText bold_text) (AlphaText header_text) (HeaderLevel level) (AlphaText paragraph_text) =
|
|
monadicIO $ shouldParseTo markdownDocument input tree
|
|
where
|
|
input = "**" <> bold_text <> "**\n\n" <> hashes level <> header_text <> "\n\n" <> paragraph_text
|
|
tree =
|
|
Doc
|
|
[ Paragraph (P [Bold [Text bold_text] mempty]) mempty,
|
|
Heading (H {level, text = [Text header_text]}) mempty,
|
|
Paragraph (P [Text paragraph_text]) mempty
|
|
]
|
|
|
|
code_block :: AlphaText -> AlphaText -> Property
|
|
code_block (AlphaText language) (AlphaText code) =
|
|
monadicIO $ shouldParseTo markdownDocument input tree
|
|
where
|
|
input = "```" <> language <> "\n" <> code <> "\n```"
|
|
-- the newline after the info string ends it, the one before the closing
|
|
-- fence is part of the code
|
|
tree = Doc [Code (C {language = Just language, code = code <> "\n"}) mempty]
|
|
|
|
code_block_hanging :: AlphaText -> AlphaText -> Property
|
|
code_block_hanging (AlphaText language) (AlphaText code) =
|
|
-- a fence whose closing ``` is not on a line of its own, we're only testing
|
|
-- that the parser terminates
|
|
monadicIO $ shouldParse markdownDocument ("```" <> language <> "\n" <> code <> "```")
|
|
|
|
two_blockquotes :: AlphaText -> AlphaText -> Property
|
|
two_blockquotes (AlphaText text_1) (AlphaText text_2) =
|
|
monadicIO $ shouldParseTo markdownDocument input tree
|
|
where
|
|
input = "> " <> text_1 <> "\n\n> " <> text_2
|
|
tree =
|
|
Doc
|
|
[ BlockQuote (Q [Transparent [Text text_1]]) mempty,
|
|
BlockQuote (Q [Transparent [Text text_2]]) mempty
|
|
]
|
|
|
|
item :: T.Text -> ListItem
|
|
item content = LI {content = [Transparent [Text content]]}
|
|
|
|
unorderedList :: [ListItem] -> Element
|
|
unorderedList items = List (L {list_type = Unordered {style = Nothing}, items}) mempty
|
|
|
|
orderedList :: [ListItem] -> Element
|
|
orderedList items = List (L {list_type = Ordered {start_number = Nothing, style = Nothing}, items}) mempty
|
|
|
|
unordered_list :: AlphaText -> AlphaText -> Property
|
|
unordered_list (AlphaText text_1) (AlphaText text_2) =
|
|
monadicIO $ shouldParseTo markdownDocument input tree
|
|
where
|
|
input = "- " <> text_1 <> "\n- " <> text_2
|
|
tree = Doc [unorderedList [item text_1, item text_2]]
|
|
|
|
header_after_unordered_list :: AlphaText -> AlphaText -> HeaderLevel -> Property
|
|
header_after_unordered_list (AlphaText bullet_text) (AlphaText header_text) (HeaderLevel level) =
|
|
monadicIO $ shouldParseTo markdownDocument input tree
|
|
where
|
|
input = "- " <> bullet_text <> "\n\n" <> hashes level <> header_text
|
|
tree =
|
|
Doc
|
|
[ unorderedList [item bullet_text],
|
|
Heading (H {level, text = [Text header_text]}) mempty
|
|
]
|
|
|
|
ordered_list :: AlphaText -> AlphaText -> AlphaText -> Property
|
|
ordered_list (AlphaText item_1) (AlphaText item_2) (AlphaText item_3) =
|
|
monadicIO $ shouldParseTo markdownDocument input tree
|
|
where
|
|
input = "1. " <> item_1 <> "\n2. " <> item_2 <> "\n3. " <> item_3
|
|
tree = Doc [orderedList [item item_1, item item_2, item item_3]]
|
|
|
|
multiple_ordered_lists :: AlphaText -> AlphaText -> AlphaText -> Property
|
|
multiple_ordered_lists (AlphaText item_1) (AlphaText item_2) (AlphaText item_3) =
|
|
monadicIO $ shouldParseTo markdownDocument input tree
|
|
where
|
|
input = "1. " <> item_1 <> "\n\n2. " <> item_2 <> "\n\n3. " <> item_3
|
|
tree =
|
|
Doc
|
|
[ orderedList [item item_1],
|
|
orderedList [item item_2],
|
|
orderedList [item item_3]
|
|
]
|
|
|
|
header_then_ordered_list :: AlphaText -> HeaderLevel -> AlphaText -> AlphaText -> AlphaText -> Property
|
|
header_then_ordered_list (AlphaText header_text) (HeaderLevel level) (AlphaText item_1) (AlphaText item_2) (AlphaText item_3) =
|
|
monadicIO $ shouldParseTo markdownDocument input tree
|
|
where
|
|
input = hashes level <> header_text <> "\n\n1) " <> item_1 <> "\n2) " <> item_2 <> "\n3) " <> item_3
|
|
tree =
|
|
Doc
|
|
[ Heading (H {level, text = [Text header_text]}) mempty,
|
|
orderedList [item item_1, item item_2, item item_3]
|
|
]
|
|
|
|
simple_nested_ordered_list :: AlphaText -> AlphaText -> Property
|
|
simple_nested_ordered_list (AlphaText item_1) (AlphaText item_2) =
|
|
monadicIO $ shouldParseTo markdownDocument input tree
|
|
where
|
|
input = "1) " <> item_1 <> "\n 1) " <> item_2
|
|
tree =
|
|
Doc
|
|
[ orderedList
|
|
[ LI {content = [Transparent [Text item_1], orderedList [item item_2]]}
|
|
]
|
|
]
|
|
|
|
-- - a
|
|
-- - a
|
|
-- - b
|
|
nested_unordered_list :: AlphaText -> AlphaText -> AlphaText -> Property
|
|
nested_unordered_list (AlphaText item_1) (AlphaText item_2) (AlphaText item_3) =
|
|
monadicIO $ shouldParseTo markdownDocument input tree
|
|
where
|
|
input = "- " <> item_1 <> "\n - " <> item_2 <> "\n- " <> item_3
|
|
tree =
|
|
Doc
|
|
[ unorderedList
|
|
[ LI {content = [Transparent [Text item_1], unorderedList [item item_2]]},
|
|
item item_3
|
|
]
|
|
]
|
|
|
|
greedy_plain_text :: AlphaNumText -> AlphaNumText -> AlphaNumText -> Property
|
|
greedy_plain_text (AlphaNumText pretext) (AlphaNumText shown) (AlphaNumText url) =
|
|
monadicIO $ shouldParseTo markdownDocument input tree
|
|
where
|
|
input = T.concat [pretext, "[", shown, "]", "(", url, ")"]
|
|
tree =
|
|
Doc
|
|
[ Paragraph
|
|
( P
|
|
[ Text pretext,
|
|
Link {linkText = [Text shown], url, title = Nothing, misc_attrs = mempty}
|
|
]
|
|
)
|
|
mempty
|
|
]
|
|
|
|
-- | Text written in a form the syntax says means that text has to come back
|
|
-- out as exactly that text, in one piece.
|
|
plain_text_is_literal :: MarkdownText -> Property
|
|
plain_text_is_literal (MarkdownText source) =
|
|
monadicIO $ shouldParseTo markdownDocument source.rendered tree
|
|
where
|
|
tree = Doc [Paragraph (P [Text source.literal]) mempty]
|
|
|
|
-- | The generalisation of every test above it: a generated document, rendered
|
|
-- as markdown, has to parse back to the document it was generated from.
|
|
document_round_trip :: DocSpec -> Property
|
|
document_round_trip spec =
|
|
counterexample (T.unpack source) $
|
|
monadicIO $
|
|
shouldParseTo markdownDocument source (expected spec)
|
|
where
|
|
source = render markdownSyntax spec
|