restructure the tests and assert on whole trees

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>

psb.cabal

@@ -35,7 +35,8 @@ library
 test-suite test-markdown-parse
     hs-source-dirs: tests
     type: exitcode-stdio-1.0
-    main-is: Markdown/Parse.hs
+    main-is: Main.hs
+    other-modules: Test.Gen, Test.Gen.Document, Test.Harness, Markdown.Parse
     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

src/IR.hs

@@ -4,7 +4,7 @@ import Control.Applicative ((<|>))
 import Data.Text
 
 newtype Document = Doc [Element]
-  deriving (Show)
+  deriving (Show, Eq)
 
 data Element
   = Heading Heading Attrs
@@ -25,7 +25,7 @@ data Element
   | RawBlock RawBlock Attrs
   | TaskList TaskList Attrs
   | ReferenceDefinition RefDef
-  deriving (Show)
+  deriving (Show, Eq)
 
 -- Removed: BlankLine
 
@@ -33,37 +33,37 @@ data Heading = H
   { level :: Int,
     text :: [InlineText]
   }
-  deriving (Show)
+  deriving (Show, Eq)
 
 data Code = C
   { language :: Maybe Text,
     code :: Text
   }
-  deriving (Show)
+  deriving (Show, Eq)
 
-newtype BlockQuote = Q [Element] deriving (Show)
+newtype BlockQuote = Q [Element] deriving (Show, Eq)
 
 newtype ListItem = LI
   -- children are just more elements
   { content :: [Element] -- Flatten continuations into here
   }
-  deriving (Show)
+  deriving (Show, Eq)
 
-data ListType = Ordered {start_number :: Maybe Int, style :: Maybe Text} | Unordered {style :: Maybe Text} deriving (Show)
+data ListType = Ordered {start_number :: Maybe Int, style :: Maybe Text} | Unordered {style :: Maybe Text} deriving (Show, Eq)
 
 data List = L
   { list_type :: ListType,
     items :: [ListItem]
   }
-  deriving (Show)
+  deriving (Show, Eq)
 
 newtype HTML
   = HTMLTag
   { html_content :: Text
   }
-  deriving (Show)
+  deriving (Show, Eq)
 
-newtype Paragraph = P [InlineText] deriving (Show)
+newtype Paragraph = P [InlineText] deriving (Show, Eq)
 
 data InlineText
   = Text Text -- Combined Normal and Escaped
@@ -110,14 +110,14 @@ data InlineText
   | RawInline RawInline Attrs
   | Span [InlineText] Attrs
   | LineBreak
-  deriving (Show)
+  deriving (Show, Eq)
 
 data Attrs = Attrs
   { attrId :: Maybe Text,
     attrClasses :: [Text],
     attrKV :: [(Text, Text)]
   }
-  deriving (Show)
+  deriving (Show, Eq)
 
 instance Semigroup Attrs where
   a <> b =
@@ -133,17 +133,17 @@ instance Monoid Attrs where
 data Math
   = InlineLaTeX Text
   | BlockLaTeX Text
-  deriving (Show)
+  deriving (Show, Eq)
 
 data Alignment = AlignLeft | AlignRight | AlignCenter | AlignDefault
-  deriving (Show)
+  deriving (Show, Eq)
 
 newtype TableCell = TC
   { cellContent :: [InlineText]
   }
-  deriving (Show)
+  deriving (Show, Eq)
 
-newtype TableRow = TR [TableCell] deriving (Show)
+newtype TableRow = TR [TableCell] deriving (Show, Eq)
 
 data Table = T
   { tableCaption :: Maybe [InlineText],
@@ -151,43 +151,43 @@ data Table = T
     tableBody :: [TableRow],
     columnAlignments :: Maybe [Alignment]
   }
-  deriving (Show)
+  deriving (Show, Eq)
 
-newtype DescriptionList = DL {items :: [DefinitionItem]} deriving (Show)
+newtype DescriptionList = DL {items :: [DefinitionItem]} deriving (Show, Eq)
 
 data DefinitionItem = Def
   { defTitle :: [InlineText],
     defContent :: [Element]
   }
-  deriving (Show)
+  deriving (Show, Eq)
 
-data Footnote = F {label :: Text, content :: [Element]} deriving (Show)
+data Footnote = F {label :: Text, content :: [Element]} deriving (Show, Eq)
 
-newtype TaskList = TL {items :: [Task]} deriving (Show)
+newtype TaskList = TL {items :: [Task]} deriving (Show, Eq)
 
 data Task = Ta
   { checked :: Bool,
     content :: [Element]
   }
-  deriving (Show)
+  deriving (Show, Eq)
 
 data RawInline = RI
   { format :: Text,
     content :: Text
   }
-  deriving (Show)
+  deriving (Show, Eq)
 
 data RawBlock = RB
   { format :: Text,
     content :: Text
   }
-  deriving (Show)
+  deriving (Show, Eq)
 
 data RefDef = RD
   { label :: Text,
     link :: Text
   }
-  deriving (Show)
+  deriving (Show, Eq)
 
 -- for processing math
 -- https://hackage.haskell.org/package/typst-0.6.1/docs/Typst-Parse.html#v:parseTypst

tests/Main.hs

@@ -0,0 +1,12 @@
+module Main (main) where
+
+import qualified Markdown.Parse
+import Test.Tasty (defaultMain, testGroup)
+
+main :: IO ()
+main =
+  defaultMain $
+    testGroup
+      "Parse Tests"
+      [ Markdown.Parse.tests
+      ]

tests/Markdown/Parse.hs

@@ -1,28 +1,21 @@
 {-# LANGUAGE OverloadedStrings #-}
 
-module Main where
+module Markdown.Parse (tests) where
 
-import Control.Exception (evaluate)
-import Data.Functor.Identity (Identity)
-import Data.Text (Text)
 import qualified Data.Text as T
-import Data.Void (Void)
 import IR
-import qualified Markdown
+import Test.Gen (AlphaNumText (..), AlphaText (..), AsciiText (..), EscapedText (..), HeaderLevel (..), MarkdownText (..))
-import System.Timeout (timeout)
+import Test.Gen.Document (DocSpec, expected, markdownSyntax, render)
-import Test.QuickCheck (Gen, Property, chooseInt, counterexample, elements, sized, vectorOf)
+import Test.Harness (markdownDocument, shouldParse, shouldParseTo)
-import Test.QuickCheck.Monadic (PropertyM, monadicIO, pick, run, stop)
+import Test.QuickCheck (Property, counterexample)
-import Test.Tasty (TestTree, defaultMain, testGroup)
+import Test.QuickCheck.Monadic (monadicIO)
+import Test.Tasty (TestTree, testGroup)
 import Test.Tasty.QuickCheck (testProperty)
-import Text.Megaparsec (ParseErrorBundle, ParsecT, errorBundlePretty, parse)
-
-main :: IO ()
-main = defaultMain tests
 
 tests :: TestTree
 tests =
   testGroup
-    "Parse Tests"
+    "Markdown"
     [ testProperty "all_compile" all_compiles,
       testProperty "block_html_compile_edgecase" block_html_compile_edgecase,
       testProperty "header_and_paragraph" header_and_paragraph,
@@ -38,324 +31,199 @@ tests =
       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 "greedy_plain_text" greedy_plain_text,
-      -- testProperty "" ,
+      testProperty "plain_text_is_literal" plain_text_is_literal,
+      testProperty "document_round_trip" document_round_trip
     ]
 
--- Hedgehog's Range.linear grows the upper bound with the size of the test
+hashes :: Int -> T.Text
--- case, this is the same thing in terms of QuickCheck's sizing
+hashes level = T.replicate level "#"
-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
+all_compiles :: AsciiText -> Property
-textOf char_gen lo hi = do
+all_compiles (AsciiText input) = monadicIO $ shouldParse markdownDocument input
-  len <- linear lo hi
-  T.pack <$> vectorOf len char_gen
 
-ascii :: Gen Char
+block_html_compile_edgecase :: AlphaNumText -> AlphaNumText -> AlphaNumText -> Property
-ascii = elements ['\0' .. '\127']
+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]
 
-alpha :: Gen Char
+header_and_paragraph :: AlphaText -> HeaderLevel -> AlphaText -> Property
-alpha = elements (['a' .. 'z'] <> ['A' .. 'Z'])
+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
+        ]
 
-alphaNum :: Gen Char
+paragraph_and_header_and_paragraph :: AlphaText -> AlphaText -> HeaderLevel -> AlphaText -> Property
-alphaNum = elements (['a' .. 'z'] <> ['A' .. 'Z'] <> ['0' .. '9'])
+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
+        ]
 
--- timeout of 1 second, all of these tests should be completely clear of that, if they run longer they should fail
+bold_and_header_and_paragraph :: AlphaText -> AlphaText -> HeaderLevel -> AlphaText -> Property
-generic_parse :: Text -> PropertyM IO (Maybe (Either (ParseErrorBundle Text Void) Document))
+bold_and_header_and_paragraph (AlphaText bold_text) (AlphaText header_text) (HeaderLevel level) (AlphaText paragraph_text) =
-generic_parse inp = run $ timeout 1000000 $ evaluate $ parse (Markdown.document :: ParsecT Void Text Identity IR.Document) "test_input" inp
+  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
+        ]
 
--- the equivalent of Hedgehog's `success`
+code_block :: AlphaText -> AlphaText -> Property
-succeed :: PropertyM IO ()
+code_block (AlphaText language) (AlphaText code) =
-succeed = pure ()
+  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]
 
--- the equivalent of Hedgehog's `fail`
+code_block_hanging :: AlphaText -> AlphaText -> Property
-failWith :: String -> PropertyM IO a
+code_block_hanging (AlphaText language) (AlphaText code) =
-failWith message = stop $ counterexample message False
+  -- 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 <> "```")
 
-all_compiles :: Property
+two_blockquotes :: AlphaText -> AlphaText -> Property
-all_compiles = monadicIO $ do
+two_blockquotes (AlphaText text_1) (AlphaText text_2) =
-  xs <- pick $ textOf ascii 0 100
+  monadicIO $ shouldParseTo markdownDocument input tree
-  parsed <- generic_parse xs
+  where
-  case parsed of
+    input = "> " <> text_1 <> "\n\n> " <> text_2
-    Nothing -> failWith "Hit Timeout"
+    tree =
-    (Just (Right _)) -> succeed
+      Doc
-    (Just (Left e)) -> failWith $ errorBundlePretty e
+        [ BlockQuote (Q [Transparent [Text text_1]]) mempty,
+          BlockQuote (Q [Transparent [Text text_2]]) mempty
+        ]
 
-block_html_compile_edgecase :: Property
+item :: T.Text -> ListItem
-block_html_compile_edgecase = monadicIO $ do
+item content = LI {content = [Transparent [Text content]]}
-  let gen = pick $ textOf alphaNum 0 10
-  tagName <- gen
-  misc1 <- gen
-  misc2 <- gen
-  parsed <- generic_parse $ (T.concat ["<", tagName, ">", misc1, "</", tagName, "> ", misc2])
-  case parsed of
-    Nothing -> failWith "Hit Timeout"
-    (Just (Right _)) -> succeed
-    (Just (Left e)) -> failWith $ errorBundlePretty e
 
-header_and_paragraph :: Property
+unorderedList :: [ListItem] -> Element
-header_and_paragraph = monadicIO $ do
+unorderedList items = List (L {list_type = Unordered {style = Nothing}, items}) mempty
-  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
+orderedList :: [ListItem] -> Element
+orderedList items = List (L {list_type = Ordered {start_number = Nothing, style = Nothing}, items}) mempty
 
-  parsed <- generic_parse input
+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]]
 
-  case parsed of
+header_after_unordered_list :: AlphaText -> AlphaText -> HeaderLevel -> Property
-    Nothing -> failWith "Hit Timeout"
+header_after_unordered_list (AlphaText bullet_text) (AlphaText header_text) (HeaderLevel level) =
-    (Just (Right (Doc [Heading (H {level = header_level, text = [Text (header_text)]}) _, Paragraph (P ([Text paragraph_text])) _]))) -> succeed
+  monadicIO $ shouldParseTo markdownDocument input tree
-    (Just (Right tree)) -> failWith $ "Incorrect syntax tree: " <> show tree
+  where
-    (Just (Left e)) -> failWith $ errorBundlePretty e
+    input = "- " <> bullet_text <> "\n\n" <> hashes level <> header_text
+    tree =
+      Doc
+        [ unorderedList [item bullet_text],
+          Heading (H {level, text = [Text header_text]}) mempty
+        ]
 
-paragraph_and_header_and_paragraph :: Property
+ordered_list :: AlphaText -> AlphaText -> AlphaText -> Property
-paragraph_and_header_and_paragraph = monadicIO $ do
+ordered_list (AlphaText item_1) (AlphaText item_2) (AlphaText item_3) =
-  paragraph1_text <- pick $ textOf alpha 1 10
+  monadicIO $ shouldParseTo markdownDocument input tree
-  header_text <- pick $ textOf alpha 1 10
+  where
-  header_level <- pick $ linear 1 6
+    input = "1. " <> item_1 <> "\n2. " <> item_2 <> "\n3. " <> item_3
-  paragraph2_text <- pick $ textOf alpha 1 10
+    tree = Doc [orderedList [item item_1, item item_2, item item_3]]
 
-  let input = paragraph1_text <> "\n\n" <> (T.pack $ take header_level $ repeat '#') <> header_text <> "\n\n" <> paragraph2_text
+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]
+        ]
 
-  parsed <- generic_parse input
+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]
+        ]
 
-  case parsed of
+simple_nested_ordered_list :: AlphaText -> AlphaText -> Property
-    Nothing -> failWith "Hit Timeout"
+simple_nested_ordered_list (AlphaText item_1) (AlphaText item_2) =
-    (Just (Right (Doc [Paragraph (P ([Text paragarph1_text])) _, Heading (H {level = header_level, text = [Text (header_text)]}) _, Paragraph (P ([Text paragraph2_text])) _]))) -> succeed
+  monadicIO $ shouldParseTo markdownDocument input tree
-    (Just (Right tree)) -> failWith $ "Incorrect syntax tree: " <> show tree
+  where
-    (Just (Left e)) -> failWith $ errorBundlePretty e
+    input = "1) " <> item_1 <> "\n    1) " <> item_2
-
+    tree =
-bold_and_header_and_paragraph :: Property
+      Doc
-bold_and_header_and_paragraph = monadicIO $ do
+        [ orderedList
-  bold_text <- pick $ textOf alpha 1 10
+            [ LI {content = [Transparent [Text item_1], orderedList [item item_2]]}
-  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 -> 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 = 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 -> 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 = 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 -> failWith "Hit Timeout"
-    -- we're just testing for hanging
-    (Just (Right _)) -> succeed
-    (Just (Left e)) -> failWith $ errorBundlePretty e
-
-two_blockquotes :: Property
-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
-
-  parsed <- generic_parse input
-
-  case parsed of
-    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 = 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
-
-  parsed <- generic_parse input
-
-  case parsed of
-    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 = monadicIO $ do
-  let text_gen = pick $ textOf alpha 1 10
-  bullet_text <- text_gen
-  header_text <- text_gen
-  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 -> 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 = monadicIO $ do
-  let text_gen = pick $ textOf alpha 1 10
-  item_1 <- text_gen
-  item_2 <- text_gen
-  item_3 <- text_gen
-  let input = "1. " <> item_1 <> "\n2. " <> item_2 <> "\n3. " <> item_3
-
-  parsed <- generic_parse input
-
-  case parsed of
-    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 = monadicIO $ do
-  let text_gen = pick $ textOf alpha 1 10
-  item_1 <- text_gen
-  item_2 <- text_gen
-  item_3 <- text_gen
-  let input = "1. " <> item_1 <> "\n\n2. " <> item_2 <> "\n\n3. " <> item_3
-
-  parsed <- generic_parse input
-  case parsed of
-    Nothing -> failWith "Hit Timeout"
-    ( Just
-        ( Right
-            ( Doc
-                [ 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]]}]}) _
-                  ]
-              )
-          )
-      ) -> 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 = 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 -> failWith "Hit Timeout"
-    ( Just
-        ( Right
-            ( Doc
-                [ List (L {list_type = Ordered {}, items = [LI {content = [Transparent [Text item_1], List (L {list_type = Ordered {}, items = [LI {content = [Transparent [Text item_2]]}]}) _]}]}) _
-                  ]
-              )
-          )
-      ) -> 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 :: AlphaText -> AlphaText -> AlphaText -> Property
-nested_unordered_list = monadicIO $ do
+nested_unordered_list (AlphaText item_1) (AlphaText item_2) (AlphaText item_3) =
-  let text_gen = pick $ textOf alpha 1 10
+  monadicIO $ shouldParseTo markdownDocument input tree
-  item_1 <- text_gen
+  where
-  item_2 <- text_gen
+    input = "- " <> item_1 <> "\n    - " <> item_2 <> "\n- " <> item_3
-  item_3 <- text_gen
+    tree =
-  let input = "- " <> item_1 <> "\n    - " <> item_2 <> "\n- " <> item_3
+      Doc
+        [ unorderedList
+            [ LI {content = [Transparent [Text item_1], unorderedList [item item_2]]},
+              item item_3
+            ]
+        ]
 
-  parsed <- generic_parse input
+greedy_plain_text :: AlphaNumText -> AlphaNumText -> AlphaNumText -> Property
-  case parsed of
+greedy_plain_text (AlphaNumText pretext) (AlphaNumText shown) (AlphaNumText url) =
-    Nothing -> failWith "Hit Timeout"
+  monadicIO $ shouldParseTo markdownDocument input tree
-    ( Just
+  where
-        ( Right
+    input = T.concat [pretext, "[", shown, "]", "(", url, ")"]
-            ( Doc
+    tree =
-                [ 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]]}]}) _
+      Doc
-                  ]
+        [ Paragraph
-              )
+            ( P
-          )
+                [ Text pretext,
-      ) -> succeed
+                  Link {linkText = [Text shown], url, title = Nothing, misc_attrs = mempty}
-    (Just (Right tree)) -> failWith $ "Incorrect syntax tree: " <> show tree
+                ]
-    (Just (Left e)) -> failWith $ errorBundlePretty e
+            )
+            mempty
+        ]
 
--- ##
+-- | Text written in a form the syntax says means that text has to come back
--- 1)
+-- out as exactly that text, in one piece.
--- 2)
+plain_text_is_literal :: MarkdownText -> Property
--- 3)
+plain_text_is_literal (MarkdownText source) =
-header_then_ordered_list :: Property
+  monadicIO $ shouldParseTo markdownDocument source.rendered tree
-header_then_ordered_list = monadicIO $ do
+  where
-  let text_gen = pick $ textOf alpha 1 10
+    tree = Doc [Paragraph (P [Text source.literal]) mempty]
-  header <- text_gen
-  header_level <- pick $ linear 1 6
-  item_1 <- text_gen
-  item_2 <- text_gen
-  item_3 <- text_gen
-  let input = (T.pack $ take header_level $ repeat '#') <> header <> "\n\n1) " <> item_1 <> "\n2) " <> item_2 <> "\n3) " <> item_3
 
-  parsed <- generic_parse input
+-- | The generalisation of every test above it: a generated document, rendered
-
+-- as markdown, has to parse back to the document it was generated from.
-  case parsed of
+document_round_trip :: DocSpec -> Property
-    Nothing -> failWith "Hit Timeout"
+document_round_trip spec =
-    ( Just
+  counterexample (T.unpack source) $
-        ( Right
+    monadicIO $
-            ( Doc
+      shouldParseTo markdownDocument source (expected spec)
-                [ Heading (H {level = header_level, text = header}) _,
+  where
-                  List
+    source = render markdownSyntax spec
-                    ( 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
-
-greedy_plain_text :: Property
-greedy_plain_text = monadicIO $ do
-  let text_gen = pick $ textOf alphaNum 1 10
-  pretext <- text_gen
-  shown <- text_gen
-  link <- text_gen
-
-  parsed <- generic_parse $ T.concat [pretext, "[", shown, "]", "(", link, ")"]
-
-  case parsed of
-    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

tests/Test/Gen.hs

@@ -0,0 +1,179 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+-- | Generators shared by the parser test suites.
+--
+-- Everything a property generates lives behind a newtype with an `Arbitrary`
+-- instance rather than being pulled in with `pick`. `pick` embeds its value
+-- with `forAll (return a)`, which cannot shrink, so a failing property would
+-- report whatever random 10 character string happened to trip it. Going
+-- through `Arbitrary` gets shrinking back, at the cost of having to write the
+-- shrinkers by hand.
+--
+-- Those shrinkers have to preserve the invariants their generator established
+-- (non-empty, alphabet, ranges). A shrunk counterexample that no longer
+-- satisfies what the property assumes is worse than no shrinking at all, it
+-- reports a failure for an input the test was never making a claim about.
+module Test.Gen
+  ( -- * sized primitives
+    linear,
+    textOf,
+    asciiChar,
+    alphaChar,
+    alphaNumChar,
+    wordsOf,
+
+    -- * shrinking
+    shrinkTextWith,
+
+    -- * wrappers
+    AsciiText (..),
+    AlphaText (..),
+    AlphaNumText (..),
+    HeaderLevel (..),
+
+    -- * escaping
+    Escaper (..),
+    backslashEscaper,
+    unescapable,
+    markdownEscaper,
+    escapeWith,
+    EscapedText (..),
+    escapedText,
+    MarkdownText (..),
+  )
+where
+
+import Data.Text (Text)
+import qualified Data.Text as T
+import Test.QuickCheck (Arbitrary (arbitrary, shrink), Gen, chooseInt, elements, frequency, sized, suchThat, vectorOf)
+
+-- | Hedgehog's `Range.linear` grows its upper bound with the size of the test
+-- case, this is the same thing in terms of QuickCheck's size parameter.
+linear :: Int -> Int -> Gen Int
+linear lo hi = sized $ \size -> chooseInt (lo, lo + ((hi - lo) * min size 99) `div` 99)
+
+textOf :: Gen Char -> Int -> Int -> Gen Text
+textOf char_gen lo hi = do
+  len <- linear lo hi
+  T.pack <$> vectorOf len char_gen
+
+asciiChar :: Gen Char
+asciiChar = elements ['\0' .. '\127']
+
+alphaChar :: Gen Char
+alphaChar = elements (['a' .. 'z'] <> ['A' .. 'Z'])
+
+alphaNumChar :: Gen Char
+alphaNumChar = elements (['a' .. 'z'] <> ['A' .. 'Z'] <> ['0' .. '9'])
+
+-- | One to three alphanumeric words separated by single spaces. Never starts or
+-- ends with a space, so it can sit directly after a block marker without the
+-- marker's own trailing space being ambiguous.
+wordsOf :: Gen Text
+wordsOf = do
+  count <- chooseInt (1, 3)
+  T.unwords <$> vectorOf count (textOf alphaNumChar 1 8)
+
+-- | Shrink by taking shorter prefixes, dropping any that no longer satisfy the
+-- predicate the generator guaranteed. Prefixes keep the first character, which
+-- is what stops a shrunk value from acquiring a leading space or a digit where
+-- the original had a letter.
+shrinkTextWith :: (Text -> Bool) -> Text -> [Text]
+shrinkTextWith valid t = filter valid [T.take n t | n <- [1 .. T.length t - 1]]
+
+newtype AsciiText = AsciiText Text
+  deriving (Show)
+
+instance Arbitrary AsciiText where
+  arbitrary = AsciiText <$> textOf asciiChar 0 100
+  shrink (AsciiText t) = AsciiText <$> shrinkTextWith (const True) t
+
+newtype AlphaText = AlphaText Text
+  deriving (Show)
+
+instance Arbitrary AlphaText where
+  arbitrary = AlphaText <$> textOf alphaChar 1 10
+  shrink (AlphaText t) = AlphaText <$> shrinkTextWith (not . T.null) t
+
+newtype AlphaNumText = AlphaNumText Text
+  deriving (Show)
+
+instance Arbitrary AlphaNumText where
+  arbitrary = AlphaNumText <$> textOf alphaNumChar 1 10
+  shrink (AlphaNumText t) = AlphaNumText <$> shrinkTextWith (not . T.null) t
+
+newtype HeaderLevel = HeaderLevel Int
+  deriving (Show)
+
+instance Arbitrary HeaderLevel where
+  arbitrary = HeaderLevel <$> chooseInt (1, 6)
+  shrink (HeaderLevel level) = HeaderLevel <$> [1 .. level - 1]
+
+-- | How a syntax lets you write a character that would otherwise be markup.
+--
+-- `escapeChar` is Nothing for a syntax with no escape mechanism at all, in
+-- which case the only way to get a special character into plain text is not to
+-- generate one. Markdown is currently in that boat.
+data Escaper = Escaper
+  { specialChars :: [Char],
+    escapeChar :: Maybe (Char -> Text)
+  }
+
+backslashEscaper :: [Char] -> Escaper
+backslashEscaper cs = Escaper {specialChars = cs, escapeChar = Just $ \c -> T.pack ['\\', c]}
+
+unescapable :: [Char] -> Escaper
+unescapable cs = Escaper {specialChars = cs, escapeChar = Nothing}
+
+-- | The characters that start markup in the Markdown parser's inline layer.
+-- \`*[~ are the ones `plain_text` breaks a text node on, _ starts an underline
+-- and ! an image, both of which are only recognised at the start of an inline
+-- run. Markdown.hs has no backslash escape handling, so this is `unescapable`.
+markdownEscaper :: Escaper
+markdownEscaper = unescapable "`*[~_!<"
+
+-- | A piece of source text paired with the literal it is supposed to parse to.
+-- For an escaping syntax these differ, for `unescapable` they are equal because
+-- the only representable literals are the ones needing no escape.
+data EscapedText = EscapedText
+  { rendered :: Text,
+    literal :: Text
+  }
+  deriving (Show)
+
+-- | Write a literal out in a form the syntax will read back as that literal.
+escapeWith :: Escaper -> Text -> Text
+escapeWith escaper = T.concatMap render
+  where
+    render c = case escaper.escapeChar of
+      Just escape | c `elem` escaper.specialChars -> escape c
+      _ -> T.singleton c
+
+-- | Generate a literal the syntax can represent, paired with its source form.
+--
+-- Which literals are representable depends on the escaper: one with an escape
+-- mechanism can carry any special character, one without can only carry the
+-- characters that aren't special in the first place.
+escapedText :: Escaper -> Gen Char -> Int -> Int -> Gen EscapedText
+escapedText escaper base lo hi = escaped escaper <$> textOf char lo hi
+  where
+    ordinary = base `suchThat` (`notElem` escaper.specialChars)
+    char = case escaper.escapeChar of
+      -- nothing needing an escape can be represented, so don't generate it
+      Nothing -> ordinary
+      Just _ -> frequency [(3, ordinary), (1, elements escaper.specialChars)]
+
+escaped :: Escaper -> Text -> EscapedText
+escaped escaper t = EscapedText {literal = t, rendered = escapeWith escaper t}
+
+-- | Text destined for the Markdown parser's inline layer, in source form and in
+-- the form it should come back out as. The two are equal for as long as
+-- `markdownEscaper` is `unescapable`; pointing it at `backslashEscaper` once
+-- Markdown.hs handles escapes turns every property using this into a test of
+-- that handling, without the properties themselves changing.
+newtype MarkdownText = MarkdownText EscapedText
+  deriving (Show)
+
+instance Arbitrary MarkdownText where
+  arbitrary = MarkdownText <$> escapedText markdownEscaper alphaNumChar 1 20
+  shrink (MarkdownText t) = MarkdownText . escaped markdownEscaper <$> shrinkTextWith (not . T.null) t.literal

tests/Test/Gen/Document.hs

@@ -0,0 +1,289 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+-- | Generating whole documents.
+--
+-- A `DocSpec` is a description of a document that can be turned into both the
+-- source text to feed the parser and the `IR.Document` that source is supposed
+-- to parse to. Generating the spec rather than a source string is what lets the
+-- two stay in step under shrinking, a shrunk spec re-renders and re-derives its
+-- own expectation.
+--
+-- Rendering goes through a `Syntax` so the Djot suite can reuse the spec type
+-- and the expectations, and only supply its own surface syntax.
+--
+-- The grammar here is deliberately a subset of what Markdown.hs accepts. It
+-- leaves out the constructs that do not currently round trip:
+--
+--   * fenced code blocks, `fencedCodeBlock` inverts its language test and
+--     reports Nothing for a fence that names a language
+--   * multi line block quotes, the first line's plain text runs past the
+--     newline and swallows the following lines
+--   * underlines and images, both are only recognised at the very start of an
+--     inline run because _ and ! are missing from the set of characters plain
+--     text stops at
+--
+-- Adding any of those to the generator once the parser handles them is a
+-- one-constructor change, which is the point of generating documents rather
+-- than writing the cases out by hand.
+module Test.Gen.Document
+  ( DocSpec (..),
+    BlockSpec (..),
+    ItemSpec (..),
+    InlineSpec (..),
+    Marker (..),
+    Run,
+    mkRun,
+    Syntax (..),
+    markdownSyntax,
+    render,
+    expected,
+  )
+where
+
+import Data.Text (Text)
+import qualified Data.Text as T
+import IR
+import Test.Gen (shrinkTextWith, wordsOf)
+import Test.QuickCheck (Arbitrary (arbitrary, shrink), Gen, chooseInt, elements, frequency, shrinkList, sized, vectorOf)
+
+newtype DocSpec = DocSpec [BlockSpec]
+  deriving (Show)
+
+data BlockSpec
+  = ParagraphS Run
+  | HeadingS Int Run
+  | -- a single line, see the note above about multi line quotes
+    QuoteS Run
+  | ListS Marker [ItemSpec]
+  deriving (Show)
+
+-- | A list item, optionally followed by a nested list of its own. The nested
+-- list's items are flat, one level of nesting is enough to exercise the
+-- indentation handling.
+data ItemSpec = ItemS Run (Maybe (Marker, [Run]))
+  deriving (Show)
+
+-- | The character a list marker is written with. Carried in the spec so that a
+-- failure reports which one was in play, and so shrinking can normalise it.
+data Marker
+  = Bullet Char
+  | Numbered Char
+  deriving (Show)
+
+data InlineSpec
+  = PlainS Text
+  | BoldS Text
+  | ItalicS Text
+  | CrossedS Text
+  | CodeS Text
+  | LinkS Text Text
+  deriving (Show)
+
+-- | An inline run. Adjacent plain pieces are merged, the parser would produce a
+-- single text node for them and the expectation has to match.
+type Run = [InlineSpec]
+
+mkRun :: [InlineSpec] -> Run
+mkRun (PlainS a : PlainS b : rest) = mkRun (PlainS (a <> b) : rest)
+mkRun (x : rest) = x : mkRun rest
+mkRun [] = []
+
+-- * generation
+
+instance Arbitrary DocSpec where
+  arbitrary = sized $ \size -> do
+    count <- chooseInt (1, 1 + min 3 (size `div` 8))
+    DocSpec <$> vectorOf count blockSpec
+
+  -- an empty document is legitimate, `document` is a `many`
+  shrink (DocSpec blocks) = DocSpec <$> shrinkList shrinkBlock blocks
+
+blockSpec :: Gen BlockSpec
+blockSpec =
+  frequency
+    [ (4, ParagraphS <$> runSpec),
+      (2, HeadingS <$> chooseInt (1, 6) <*> runSpec),
+      (2, QuoteS <$> runSpec),
+      (2, ListS <$> markerSpec <*> itemsSpec)
+    ]
+
+markerSpec :: Gen Marker
+markerSpec =
+  frequency
+    [ (1, Bullet <$> elements "-*+"),
+      (1, Numbered <$> elements ".)")
+    ]
+
+itemsSpec :: Gen [ItemSpec]
+itemsSpec = do
+  count <- chooseInt (1, 3)
+  vectorOf count itemSpec
+
+itemSpec :: Gen ItemSpec
+itemSpec = ItemS <$> runSpec <*> frequency [(3, pure Nothing), (1, Just <$> nested)]
+  where
+    nested = do
+      marker <- markerSpec
+      count <- chooseInt (1, 2)
+      runs <- vectorOf count runSpec
+      pure (marker, runs)
+
+runSpec :: Gen Run
+runSpec = do
+  count <- chooseInt (1, 4)
+  mkRun <$> vectorOf count inlineSpec
+
+inlineSpec :: Gen InlineSpec
+inlineSpec =
+  frequency
+    [ (5, PlainS <$> wordsOf),
+      (1, BoldS <$> wordsOf),
+      (1, ItalicS <$> wordsOf),
+      (1, CrossedS <$> wordsOf),
+      (1, CodeS <$> wordsOf),
+      -- a url with a space in it would be parsed as a url plus a title
+      (1, LinkS <$> wordsOf <*> word)
+    ]
+  where
+    word = T.filter (/= ' ') <$> wordsOf
+
+-- * shrinking
+
+shrinkBlock :: BlockSpec -> [BlockSpec]
+shrinkBlock (ParagraphS run) = ParagraphS <$> shrinkRun run
+shrinkBlock (HeadingS level run) =
+  [ParagraphS run]
+    <> [HeadingS level' run | level' <- [1 .. level - 1]]
+    <> (HeadingS level <$> shrinkRun run)
+shrinkBlock (QuoteS run) = [ParagraphS run] <> (QuoteS <$> shrinkRun run)
+shrinkBlock (ListS marker items) =
+  [ParagraphS run | ItemS run _ <- take 1 items]
+    <> (ListS <$> shrinkMarker marker <*> pure items)
+    -- `some listItem`, a list with no items is not a list
+    <> [ListS marker items' | items' <- shrinkList shrinkItem items, not (null items')]
+
+shrinkMarker :: Marker -> [Marker]
+shrinkMarker (Bullet c) = [Bullet '-' | c /= '-']
+shrinkMarker (Numbered c) = [Numbered '.' | c /= '.']
+
+shrinkItem :: ItemSpec -> [ItemSpec]
+shrinkItem (ItemS run nested) =
+  [ItemS run Nothing | Just _ <- [nested]]
+    <> (ItemS <$> shrinkRun run <*> pure nested)
+    <> [ItemS run (Just (marker, runs')) | Just (marker, runs) <- [nested], runs' <- shrinkList shrinkRun runs, not (null runs')]
+
+-- | A run is never empty, an empty one renders to nothing at all and the block
+-- around it stops being the block the spec describes.
+shrinkRun :: Run -> [Run]
+shrinkRun run = [mkRun shrunk | shrunk <- shrinkList shrinkInline run, not (null shrunk)]
+
+shrinkInline :: InlineSpec -> [InlineSpec]
+shrinkInline (PlainS t) = PlainS <$> shrinkContent t
+shrinkInline (BoldS t) = [PlainS t] <> (BoldS <$> shrinkContent t)
+shrinkInline (ItalicS t) = [PlainS t] <> (ItalicS <$> shrinkContent t)
+shrinkInline (CrossedS t) = [PlainS t] <> (CrossedS <$> shrinkContent t)
+shrinkInline (CodeS t) = [PlainS t] <> (CodeS <$> shrinkContent t)
+shrinkInline (LinkS t url) =
+  [PlainS t]
+    <> [LinkS t' url | t' <- shrinkContent t]
+    <> [LinkS t url' | url' <- shrinkContent url, not (T.any (== ' ') url')]
+
+shrinkContent :: Text -> [Text]
+shrinkContent = shrinkTextWith (\t -> not (T.null t) && T.last t /= ' ')
+
+-- * rendering
+
+-- | The surface syntax a spec is written out in. The expectations are shared,
+-- only this differs between Markdown and Djot.
+data Syntax = Syntax
+  { renderInline :: InlineSpec -> Text,
+    renderHeading :: Int -> Text -> Text,
+    renderQuote :: Text -> Text,
+    -- | marker, depth, one based index within the list, content
+    renderItem :: Marker -> Int -> Int -> Text -> Text,
+    blockSeparator :: Text
+  }
+
+markdownSyntax :: Syntax
+markdownSyntax =
+  Syntax
+    { renderInline = \case
+        PlainS t -> t
+        BoldS t -> "**" <> t <> "**"
+        ItalicS t -> "*" <> t <> "*"
+        CrossedS t -> "~~" <> t <> "~~"
+        CodeS t -> "`" <> t <> "`"
+        LinkS t url -> "[" <> t <> "](" <> url <> ")",
+      renderHeading = \level content -> T.replicate level "#" <> " " <> content,
+      renderQuote = \content -> "> " <> content,
+      renderItem = \marker depth index content ->
+        T.replicate depth "    " <> marked marker index <> " " <> content,
+      blockSeparator = "\n\n"
+    }
+  where
+    marked (Bullet c) _ = T.singleton c
+    marked (Numbered c) index = T.pack (show index) <> T.singleton c
+
+render :: Syntax -> DocSpec -> Text
+render syntax (DocSpec blocks) = T.intercalate syntax.blockSeparator $ map (renderBlock syntax) blocks
+
+renderBlock :: Syntax -> BlockSpec -> Text
+renderBlock syntax = \case
+  ParagraphS run -> renderRun syntax run
+  HeadingS level run -> syntax.renderHeading level (renderRun syntax run)
+  QuoteS run -> syntax.renderQuote (renderRun syntax run)
+  ListS marker items -> T.intercalate "\n" $ renderItems syntax marker 0 items
+
+renderItems :: Syntax -> Marker -> Int -> [ItemSpec] -> [Text]
+renderItems syntax marker depth items = concat $ zipWith one [1 ..] items
+  where
+    one index (ItemS run nested) =
+      syntax.renderItem marker depth index (renderRun syntax run)
+        : case nested of
+          Nothing -> []
+          Just (child_marker, runs) ->
+            renderItems syntax child_marker (depth + 1) [ItemS run' Nothing | run' <- runs]
+
+-- | Inline elements are written with nothing between them. Plain pieces carry
+-- their own spacing and adjacent plain pieces have already been merged, so a
+-- separator here would be text the expectation does not account for.
+renderRun :: Syntax -> Run -> Text
+renderRun syntax = T.concat . map syntax.renderInline
+
+-- * expectations
+
+expected :: DocSpec -> Document
+expected (DocSpec blocks) = Doc $ map expectedBlock blocks
+
+expectedBlock :: BlockSpec -> Element
+expectedBlock = \case
+  ParagraphS run -> Paragraph (P (expectedRun run)) mempty
+  HeadingS level run -> Heading (H {level, text = expectedRun run}) mempty
+  QuoteS run -> BlockQuote (Q [Transparent (expectedRun run)]) mempty
+  ListS marker items -> List (expectedList marker items) mempty
+
+expectedList :: Marker -> [ItemSpec] -> List
+expectedList marker items = L {list_type = expectedType marker, items = map expectedItem items}
+
+expectedType :: Marker -> ListType
+expectedType (Bullet _) = Unordered {style = Nothing}
+expectedType (Numbered _) = Ordered {start_number = Nothing, style = Nothing}
+
+expectedItem :: ItemSpec -> ListItem
+expectedItem (ItemS run nested) = LI {content = Transparent (expectedRun run) : child}
+  where
+    child = case nested of
+      Nothing -> []
+      Just (marker, runs) -> [List (expectedList marker [ItemS run' Nothing | run' <- runs]) mempty]
+
+expectedRun :: Run -> [InlineText]
+expectedRun = map expectedInline
+
+expectedInline :: InlineSpec -> InlineText
+expectedInline = \case
+  PlainS t -> Text t
+  BoldS t -> Bold [Text t] mempty
+  ItalicS t -> Italic [Text t] mempty
+  CrossedS t -> Crossed [Text t] mempty
+  CodeS t -> InlineCode t mempty
+  LinkS t url -> Link {linkText = [Text t], url, title = Nothing, misc_attrs = mempty}

tests/Test/Harness.hs

@@ -0,0 +1,93 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+-- | Running a document parser inside a property and turning the result into a
+-- QuickCheck verdict. Everything here is parser agnostic so the Djot suite can
+-- share it with the Markdown one.
+module Test.Harness
+  ( DocumentParser,
+    markdownDocument,
+    shouldParseTo,
+    shouldParse,
+    succeed,
+    failWith,
+  )
+where
+
+import Control.Exception (evaluate)
+import Data.Functor.Identity (Identity)
+import Data.Text (Text)
+import Data.Void (Void)
+import IR (Document)
+import qualified Markdown
+import System.Timeout (timeout)
+import Test.QuickCheck (counterexample)
+import Test.QuickCheck.Monadic (PropertyM, run, stop)
+import Text.Megaparsec (ParsecT, errorBundlePretty, parse)
+
+-- | A document parser pinned to the concrete stream and monad the tests use.
+type DocumentParser = ParsecT Void Text Identity Document
+
+markdownDocument :: DocumentParser
+markdownDocument = Markdown.document
+
+-- | What running a parser over an input told us. Timeouts are a failure mode in
+-- their own right because a parser bug is much more likely to loop than to
+-- throw.
+data Outcome
+  = TimedOut
+  | Failed String
+  | Passed
+
+-- | 1 second, every test here should finish orders of magnitude below that
+parseTimeout :: Int
+parseTimeout = 1000000
+
+-- | Both the parse and the check on its result happen inside the timeout, a
+-- comparison against a lazily built infinite tree would otherwise hang outside
+-- of it.
+attempt :: DocumentParser -> Text -> (Document -> Maybe String) -> PropertyM IO Outcome
+attempt parser input check = do
+  result <- run $
+    timeout parseTimeout $ do
+      parsed <- evaluate $ parse parser "test_input" input
+      case parsed of
+        Left e -> pure . Failed $ errorBundlePretty e
+        Right actual -> case check actual of
+          Nothing -> pure Passed
+          Just message -> do
+            -- force the message, building it is what forces the tree
+            _ <- evaluate $ length message
+            pure $ Failed message
+  pure $ maybe TimedOut id result
+
+verdict :: Outcome -> PropertyM IO ()
+verdict TimedOut = failWith "Hit Timeout"
+verdict (Failed message) = failWith message
+verdict Passed = succeed
+
+-- | The input must parse to exactly this tree.
+shouldParseTo :: DocumentParser -> Text -> Document -> PropertyM IO ()
+shouldParseTo parser input expected = verdict =<< attempt parser input check
+  where
+    check actual
+      | actual == expected = Nothing
+      | otherwise =
+          Just $
+            unlines
+              [ "input:    " <> show input,
+                "expected: " <> show expected,
+                "actual:   " <> show actual
+              ]
+
+-- | The input must parse, with no claim about what it parses to. For the cases
+-- where the parser only has to not fall over.
+shouldParse :: DocumentParser -> Text -> PropertyM IO ()
+shouldParse parser input = verdict =<< attempt parser input (const Nothing)
+
+-- | 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