property tests for the djot parser

Expectations come from the djot syntax reference and IR.hs rather than
from what the parser currently produces, so a failure is evidence of a
bug instead of a record of one. 55 properties: 32 inline (emphasis,
verbatim, math, raw, links, images, references, autolinks, spans,
attributes, footnotes, symbols, escapes, smart punctuation) and 23 block
(headings, quotes, breaks, code fences, divs, raw blocks, every ordered
marker style and delimiter, tight vs loose items, nesting, task lists,
definition lists, tables, definitions, block attributes, round trip).

Two rules are deliberately unasserted and noted in the module header:
headings of seven or more hashes, and the general verbatim space
stripping rule, of which only the unambiguous backtick case is tested.

Three deviations the suite found, fixed in Djot.hs:

- an unclosed verbatim span failed the construct back into plain text.
  The reference says it "extends to the end of the text"; manyTill
  cannot say that on its own, it needs the eof alternative.
- a task list checkbox was recognised without the space the reference
  requires after it, so "1. [x](5)" ate a link and turned it into a
  checked item containing a list starting at 5.
- checkboxes were recognised on ordered items, but the reference gives
  them to bullet items only.

Test.Gen.Document is now shared by both suites. Syntax grew
quoteContent and listTypeFor for the two places markdown and djot
disagree about the resulting IR, and two djot facts became generator
invariants rather than assertions: adjacent markup sharing a delimiter
is ambiguous, so runs separate it, and a blank line between two lists
makes one loose list rather than two blocks, so documents never place
lists back to back.

The test suite is no longer markdown only, so it is just "tests" now.

Co-Authored-By: Claude Opus 5 <noreply@anthropic.com>

.gitignore

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

psb.cabal

@@ -30,13 +30,14 @@ library
     exposed-modules: Djot Markdown HTML Logger IR Logger.Shake Psb.Main Utilities Utilities.FilePath Utilities.Action Utilities.Javascript Utilities.CSS Templates Types Config Utilities.Bundling
     other-modules: Utilities.Parsing
     build-depends:    base, mustache >=2.4.2, shake >= 0.19.8, deriving-aeson >= 0.2.9, aeson, text >= 2.1.2, time, unordered-containers, yaml, megaparsec >= 9.7.0, transformers >= 0.6.2, bytestring
-    default-extensions: ApplicativeDo DataKinds NamedFieldPuns DerivingVia LambdaCase TypeApplications DeriveGeneric OverloadedRecordDot OverloadedRecordUpdate NamedFieldPuns DuplicateRecordFields DisambiguateRecordFields FlexibleInstances
+    default-extensions: ApplicativeDo DataKinds NamedFieldPuns DerivingVia LambdaCase TypeApplications DeriveGeneric OverloadedRecordDot NamedFieldPuns DuplicateRecordFields DisambiguateRecordFields FlexibleInstances
 
-test-suite test-markdown-parse
+test-suite tests
     hs-source-dirs: tests
     type: exitcode-stdio-1.0
-    main-is: Markdown/Parse.hs
-    build-depends: base, text, megaparsec, transformers, hedgehog, time, psb
+    main-is: Main.hs
+    other-modules: Test.Gen, Test.Gen.Document, Test.Harness, Markdown.Parse, Djot.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
     default-language: Haskell2010

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
@@ -90,6 +90,13 @@ data InlineText
         title :: Maybe Text,
         misc_attrs :: Attrs
       }
+  | -- the image equivalent of ReferenceLink, url comes from a RefDef with a
+    -- matching label
+    ReferenceImage
+      { altText :: Text,
+        label :: Text,
+        attrs :: Attrs
+      }
   | -- Markdown only DJOT uses RawInline
     HTMLInline {inline_html_content :: Text}
   | Superscript [InlineText] Attrs
@@ -103,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 =
@@ -126,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],
@@ -144,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

src/Markdown.hs

@@ -45,7 +45,15 @@ element =
       try htmlBlock <?> "HTML Block",
       paragraphBlock <?> "Paragarph"
     ]
-    <* blockEnding
+    -- a block is normally followed by a blank line or the end of input, but a
+    -- block that ends without one is the next block's problem rather than a
+    -- parse error for the whole document. requiring the ending here turned
+    -- "- a\n:" into a hard failure, because listItem has already eaten the
+    -- newline that blockEnding wants and the consumed input escapes document's
+    -- many. the try matters for the same reason optional isn't enough on its
+    -- own, blockEnding can consume one line ending before finding out there is
+    -- no second one.
+    <* optional (try blockEnding)
 
 lineEnding :: (Logger m, Characters s, HasCallStack) => Parser s m ()
 lineEnding = {-logCallStack *>-} ((try eof) <|> void newline)
@@ -137,7 +145,7 @@ fencedCodeBlock = between (string "```") (string "```") $ do
   language' <- T.pack <$> (many (notFollowedBy lineEnding *> anySingle))
   lineEnding
   code <- T.pack <$> (many ((notFollowedBy $ string "```") *> anySingle))
-  let language = if language' == "" then Just language' else Nothing
+  let language = if language' == "" then Nothing else Just language'
   pure $ Code (C {language, code}) mempty
 
 blockquoteBlock :: (Logger m, Characters s) => Parser s m Element
@@ -170,7 +178,11 @@ listBlock list_type prefix child_parser_factory nest_level = do
 
       optional ((notFollowedBy blockEnding) *> lineEnding)
 
-      child <- optional $ child_parser_factory $ nest_level + 1
+      -- the try is load bearing, optional only recovers from a failure that
+      -- consumed nothing and the child parser eats the next item's indentation
+      -- before finding out it belongs to this list's level rather than the
+      -- child's
+      child <- optional $ try $ child_parser_factory $ nest_level + 1
 
       case child of
         Just c -> pure $ LI {content = [Transparent content, List c mempty]}

tests/Djot/Parse.hs

@@ -0,0 +1,706 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+-- | Property tests for the djot parser.
+--
+-- The expectations here are written from the djot syntax reference
+-- (<https://github.com/jgm/djot/blob/master/doc/syntax.html>) and `IR`, not
+-- from what the parser currently does. A failure therefore means one of three
+-- things: the parser disagrees with the reference, the reference was read
+-- wrongly, or the IR has no faithful way to represent what the reference asks
+-- for. The comment on each property says which rule it comes from so the first
+-- can be told apart from the second.
+--
+-- Two things the reference leaves open are deliberately not asserted on:
+--
+--   * headings with more than six @#@ characters, the reference gives no
+--     maximum level
+--   * whether a space next to a verbatim delimiter is stripped in general or
+--     only when the content itself starts or ends with a backtick; only the
+--     unambiguous backtick case is tested
+module Djot.Parse (tests) where
+
+import qualified Data.Text as T
+import IR
+import Test.Gen (AlphaNumText (..), AsciiText (..), DjotText (..), EscapedText (..), HeaderLevel (..), UrlText (..), VerbatimText (..))
+import Test.Gen.Document (DocSpec, djotSyntax, expected, render)
+import Test.Harness (djotDocument, shouldParse, shouldParseTo)
+import Test.QuickCheck (Arbitrary (arbitrary, shrink), Gen, Property, chooseInt, counterexample, elements)
+import Test.QuickCheck.Monadic (monadicIO)
+import Test.Tasty (TestTree, testGroup)
+import Test.Tasty.QuickCheck (testProperty)
+
+tests :: TestTree
+tests =
+  testGroup
+    "Djot"
+    [ testGroup
+        "inline"
+        [ testProperty "emphasis_delimiters" emphasis_delimiters,
+          testProperty "braced_emphasis_delimiters" braced_emphasis_delimiters,
+          testProperty "opener_may_not_be_followed_by_space" opener_may_not_be_followed_by_space,
+          testProperty "closer_may_not_be_preceded_by_space" closer_may_not_be_preceded_by_space,
+          testProperty "highlight_insert_delete" highlight_insert_delete,
+          testProperty "verbatim_is_literal" verbatim_is_literal,
+          testProperty "verbatim_fences_match_in_length" verbatim_fences_match_in_length,
+          testProperty "verbatim_may_hold_a_backtick" verbatim_may_hold_a_backtick,
+          testProperty "unclosed_verbatim_runs_to_the_end" unclosed_verbatim_runs_to_the_end,
+          testProperty "raw_inline" raw_inline,
+          testProperty "inline_math" inline_math,
+          testProperty "display_math" display_math,
+          testProperty "inline_link" inline_link,
+          testProperty "reference_link" reference_link,
+          testProperty "empty_reference_label_is_the_text" empty_reference_label_is_the_text,
+          testProperty "inline_image" inline_image,
+          testProperty "reference_image" reference_image,
+          testProperty "empty_image_label_is_the_alt_text" empty_image_label_is_the_alt_text,
+          testProperty "autolink_url" autolink_url,
+          testProperty "autolink_email" autolink_email,
+          testProperty "span_takes_attributes" span_takes_attributes,
+          testProperty "attributes_attach_to_the_element" attributes_attach_to_the_element,
+          testProperty "attributes_stack" attributes_stack,
+          testProperty "footnote_reference" footnote_reference,
+          testProperty "symbol" symbol,
+          testProperty "escaped_punctuation_is_literal" escaped_punctuation_is_literal,
+          testProperty "backslash_space_is_a_nonbreaking_space" backslash_space_is_a_nonbreaking_space,
+          testProperty "backslash_newline_is_a_hard_break" backslash_newline_is_a_hard_break,
+          testProperty "ellipsis" ellipsis,
+          testProperty "en_dash" en_dash,
+          testProperty "em_dash" em_dash,
+          testProperty "smart_quotes" smart_quotes
+        ],
+      testGroup
+        "block"
+        [ testProperty "all_compile" all_compile,
+          testProperty "heading_levels" heading_levels,
+          testProperty "paragraphs_split_on_blank_lines" paragraphs_split_on_blank_lines,
+          testProperty "block_quote_holds_blocks" block_quote_holds_blocks,
+          testProperty "thematic_break" thematic_break,
+          testProperty "code_block_with_language" code_block_with_language,
+          testProperty "code_block_without_language" code_block_without_language,
+          testProperty "closing_fence_may_be_longer" closing_fence_may_be_longer,
+          testProperty "raw_block" raw_block,
+          testProperty "div_block" div_block,
+          testProperty "bullet_markers" bullet_markers,
+          testProperty "ordered_markers" ordered_markers,
+          testProperty "tight_list_items_are_unwrapped" tight_list_items_are_unwrapped,
+          testProperty "loose_list_items_keep_paragraphs" loose_list_items_keep_paragraphs,
+          testProperty "nested_list" nested_list,
+          testProperty "task_list" task_list,
+          testProperty "definition_list" definition_list,
+          testProperty "table" table,
+          testProperty "table_caption" table_caption,
+          testProperty "footnote_definition" footnote_definition,
+          testProperty "reference_definition" reference_definition,
+          testProperty "block_attributes" block_attributes,
+          testProperty "document_round_trip" document_round_trip
+        ]
+    ]
+
+--------------------------------------------------------------------------------
+-- helpers
+--------------------------------------------------------------------------------
+
+parses :: T.Text -> Document -> Property
+parses source tree =
+  counterexample (T.unpack source) $ monadicIO $ shouldParseTo djotDocument source tree
+
+paragraph :: [InlineText] -> Document
+paragraph content = Doc [Paragraph (P content) mempty]
+
+-- | Inline constructs are checked inside a paragraph that starts with a plain
+-- word. Several of the delimiters (@*@, @-@, @:@, @[@, @{@) mean something else
+-- entirely in the first column of a line, and that is the block layer's job to
+-- test, not the inline layer's.
+inlineIs :: T.Text -> [InlineText] -> Property
+inlineIs source content = parses ("x " <> source) (paragraph (mergeText (Text "x " : content)))
+
+-- | For the cases where the whole paragraph, prefix included, is one text node.
+literalIs :: T.Text -> T.Text -> Property
+literalIs source text = inlineIs source [Text text]
+
+-- | Adjacent text is one node, so an expectation that gained a prefix word has
+-- to be merged the same way the parser merges.
+mergeText :: [InlineText] -> [InlineText]
+mergeText (Text a : Text b : rest) = mergeText (Text (a <> b) : rest)
+mergeText (element : rest) = element : mergeText rest
+mergeText [] = []
+
+item :: T.Text -> ListItem
+item content = LI {content = [Transparent [Text content]]}
+
+classOf :: T.Text -> Attrs
+classOf name = Attrs {attrId = Nothing, attrClasses = [name], attrKV = []}
+
+--------------------------------------------------------------------------------
+-- inline: emphasis
+--------------------------------------------------------------------------------
+
+-- | "Emphasis is delimited by @_@ characters, strong by @*@ [...] Superscript
+-- is delimited by @^@ characters, subscript by @~@."
+newtype Delimiter = Delimiter Char
+  deriving (Show)
+
+instance Arbitrary Delimiter where
+  arbitrary = Delimiter <$> elements "*_^~"
+  shrink _ = []
+
+construct :: Char -> [InlineText] -> Attrs -> InlineText
+construct '*' = Bold
+construct '_' = Italic
+construct '^' = Superscript
+construct _ = Subscript
+
+emphasis_delimiters :: Delimiter -> AlphaNumText -> Property
+emphasis_delimiters (Delimiter c) (AlphaNumText t) =
+  inlineIs (d <> t <> d) [construct c [Text t] mempty]
+  where
+    d = T.singleton c
+
+-- | "Curly braces may be used, but are not required", and for @{_@ / @_}@ they
+-- are what lets the delimiters sit next to whitespace.
+braced_emphasis_delimiters :: Delimiter -> AlphaNumText -> Property
+braced_emphasis_delimiters (Delimiter c) (AlphaNumText t) =
+  inlineIs ("{" <> d <> t <> d <> "}") [construct c [Text t] mempty]
+  where
+    d = T.singleton c
+
+-- | "Cannot open if directly followed by whitespace."
+opener_may_not_be_followed_by_space :: Delimiter -> AlphaNumText -> Property
+opener_may_not_be_followed_by_space (Delimiter c) (AlphaNumText t) =
+  literalIs (d <> " " <> t <> d) (d <> " " <> t <> d)
+  where
+    d = T.singleton c
+
+-- | "Cannot close if directly preceded by whitespace."
+closer_may_not_be_preceded_by_space :: Delimiter -> AlphaNumText -> Property
+closer_may_not_be_preceded_by_space (Delimiter c) (AlphaNumText t) =
+  literalIs (d <> t <> " " <> d) (d <> t <> " " <> d)
+  where
+    d = T.singleton c
+
+-- | "@{=@ and @=}@" for highlight, "@{+@ and @+}@" for insert, "@{-@ and @-}@"
+-- for delete; for these the braces are mandatory.
+newtype BracedMarker = BracedMarker Char
+  deriving (Show)
+
+instance Arbitrary BracedMarker where
+  arbitrary = BracedMarker <$> elements "=+-"
+  shrink _ = []
+
+highlight_insert_delete :: BracedMarker -> AlphaNumText -> Property
+highlight_insert_delete (BracedMarker c) (AlphaNumText t) =
+  inlineIs ("{" <> d <> t <> d <> "}") [wrap [Text t] mempty]
+  where
+    d = T.singleton c
+    wrap = case c of
+      '=' -> Highlighted
+      '+' -> Insert
+      _ -> Crossed
+
+--------------------------------------------------------------------------------
+-- inline: verbatim, raw, math
+--------------------------------------------------------------------------------
+
+-- | "Content is treated literally, no escapes are allowed."
+verbatim_is_literal :: VerbatimText -> Property
+verbatim_is_literal (VerbatimText t) = inlineIs ("`" <> t <> "`") [InlineCode t mempty]
+
+-- | "Opening and closing backticks must match in length."
+verbatim_fences_match_in_length :: FenceLength -> VerbatimText -> Property
+verbatim_fences_match_in_length (FenceLength n) (VerbatimText t) =
+  inlineIs (fence <> t <> fence) [InlineCode t mempty]
+  where
+    fence = T.replicate n "`"
+
+newtype FenceLength = FenceLength Int
+  deriving (Show)
+
+instance Arbitrary FenceLength where
+  arbitrary = FenceLength <$> chooseInt (1, 5)
+  shrink (FenceLength n) = FenceLength <$> [1 .. n - 1]
+
+-- | "If the content starts or ends with a backtick character, a single space is
+-- removed between the opening or closing backticks and the content." A longer
+-- fence plus that space is the only way to write a leading backtick.
+verbatim_may_hold_a_backtick :: AlphaNumText -> Property
+verbatim_may_hold_a_backtick (AlphaNumText t) =
+  inlineIs ("`` `" <> t <> " ``") [InlineCode ("`" <> t) mempty]
+
+-- | "If no closing backticks are found, the verbatim span extends to the end of
+-- the [...] text."
+unclosed_verbatim_runs_to_the_end :: VerbatimText -> Property
+unclosed_verbatim_runs_to_the_end (VerbatimText t) =
+  inlineIs ("`" <> t) [InlineCode t mempty]
+
+-- | "A verbatim span followed immediately by @{=FORMAT}@ is raw content."
+raw_inline :: AlphaNumText -> VerbatimText -> Property
+raw_inline (AlphaNumText format) (VerbatimText t) =
+  inlineIs ("`" <> t <> "`{=" <> format <> "}") [RawInline (RI {format, content = t}) mempty]
+
+-- | "Put the math in a verbatim span and prefix it with @$@ (for inline math)."
+inline_math :: VerbatimText -> Property
+inline_math (VerbatimText t) =
+  inlineIs ("$`" <> t <> "`") [Math (InlineLaTeX t) mempty]
+
+-- | "[...] or @$$@ (for display math)."
+display_math :: VerbatimText -> Property
+display_math (VerbatimText t) =
+  inlineIs ("$$`" <> t <> "`") [Math (BlockLaTeX t) mempty]
+
+--------------------------------------------------------------------------------
+-- inline: links and images
+--------------------------------------------------------------------------------
+
+-- | "@[link text](url)@, with no space between the @]@ and the @(@."
+inline_link :: AlphaNumText -> UrlText -> Property
+inline_link (AlphaNumText t) (UrlText url) =
+  inlineIs ("[" <> t <> "](" <> url <> ")") [Link {linkText = [Text t], url, title = Nothing, misc_attrs = mempty}]
+
+-- | "@[link text][label]@, the label in square brackets immediately after."
+reference_link :: AlphaNumText -> AlphaNumText -> Property
+reference_link (AlphaNumText t) (AlphaNumText label) =
+  inlineIs ("[" <> t <> "][" <> label <> "]") [ReferenceLink {linkText = [Text t], label, attrs = mempty}]
+
+-- | "@[My link text][]@ [...] the link text is taken as the label."
+empty_reference_label_is_the_text :: AlphaNumText -> Property
+empty_reference_label_is_the_text (AlphaNumText t) =
+  inlineIs ("[" <> t <> "][]") [ReferenceLink {linkText = [Text t], label = t, attrs = mempty}]
+
+-- | "Images are like links but prefixed with @!@."
+inline_image :: AlphaNumText -> UrlText -> Property
+inline_image (AlphaNumText altText) (UrlText url) =
+  inlineIs ("![" <> altText <> "](" <> url <> ")") [Image {altText, url, title = Nothing, misc_attrs = mempty}]
+
+reference_image :: AlphaNumText -> AlphaNumText -> Property
+reference_image (AlphaNumText altText) (AlphaNumText label) =
+  inlineIs ("![" <> altText <> "][" <> label <> "]") [ReferenceImage {altText, label, attrs = mempty}]
+
+empty_image_label_is_the_alt_text :: AlphaNumText -> Property
+empty_image_label_is_the_alt_text (AlphaNumText altText) =
+  inlineIs ("![" <> altText <> "][]") [ReferenceImage {altText, label = altText, attrs = mempty}]
+
+-- | "A URL [...] enclosed in @<@ and @>@ [...] the contents are treated
+-- literally."
+autolink_url :: AlphaNumText -> Property
+autolink_url (AlphaNumText host) =
+  inlineIs ("<" <> target <> ">") [Link {linkText = [Text target], url = target, title = Nothing, misc_attrs = mempty}]
+  where
+    target = "https://" <> host <> ".example"
+
+-- | An email autolink gets a @mailto:@ destination, while its content stays the
+-- bare address.
+autolink_email :: AlphaNumText -> AlphaNumText -> Property
+autolink_email (AlphaNumText user) (AlphaNumText host) =
+  inlineIs ("<" <> target <> ">") [Link {linkText = [Text target], url = "mailto:" <> target, title = Nothing, misc_attrs = mempty}]
+  where
+    target = user <> "@" <> host <> ".example"
+
+--------------------------------------------------------------------------------
+-- inline: spans, attributes, references
+--------------------------------------------------------------------------------
+
+-- | "Text in square brackets that is not a link or image, followed immediately
+-- by attributes, is a span."
+span_takes_attributes :: AlphaNumText -> AlphaNumText -> Property
+span_takes_attributes (AlphaNumText t) (AlphaNumText cls) =
+  inlineIs ("[" <> t <> "]{." <> cls <> "}") [Span [Text t] (classOf cls)]
+
+-- | "Attributes [...] immediately after the element they attach to, with no
+-- intervening whitespace." @#@ is the identifier, @.@ a class, @k=v@ a pair.
+attributes_attach_to_the_element :: AlphaNumText -> AlphaNumText -> AlphaNumText -> AlphaNumText -> AlphaNumText -> Property
+attributes_attach_to_the_element (AlphaNumText t) (AlphaNumText ident) (AlphaNumText cls) (AlphaNumText key) (AlphaNumText value) =
+  inlineIs
+    ("*" <> t <> "*{#" <> ident <> " ." <> cls <> " " <> key <> "=" <> value <> "}")
+    [Bold [Text t] (Attrs {attrId = Just ident, attrClasses = [cls], attrKV = [(key, value)]})]
+
+-- | "Attributes are stackable: @element{attr1}{attr2}@."
+attributes_stack :: AlphaNumText -> AlphaNumText -> AlphaNumText -> Property
+attributes_stack (AlphaNumText t) (AlphaNumText first) (AlphaNumText second) =
+  inlineIs
+    ("*" <> t <> "*{." <> first <> "}{." <> second <> "}")
+    [Bold [Text t] (Attrs {attrId = Nothing, attrClasses = [first, second], attrKV = []})]
+
+-- | "A footnote reference is @^@ + the reference label in square brackets", as
+-- in @Here is the reference.[^foo]@.
+footnote_reference :: AlphaNumText -> Property
+footnote_reference (AlphaNumText label) =
+  inlineIs ("[^" <> label <> "]") [FootnoteReference {label, attrs = mempty}]
+
+-- | "A symbol is a word between @:@ characters."
+symbol :: AlphaNumText -> Property
+symbol (AlphaNumText name) = inlineIs (":" <> name <> ":") [Symbol name]
+
+--------------------------------------------------------------------------------
+-- inline: escapes and smart punctuation
+--------------------------------------------------------------------------------
+
+-- | "A backslash escapes any ASCII punctuation character." Every special
+-- character therefore has a plain text spelling, and text written that way has
+-- to come back out as exactly the intended literal, in one piece.
+escaped_punctuation_is_literal :: DjotText -> Property
+escaped_punctuation_is_literal (DjotText source) = literalIs source.rendered source.literal
+
+-- | "A backslash before a space is a nonbreaking space."
+backslash_space_is_a_nonbreaking_space :: AlphaNumText -> AlphaNumText -> Property
+backslash_space_is_a_nonbreaking_space (AlphaNumText before) (AlphaNumText after) =
+  literalIs (before <> "\\ " <> after) (before <> "\160" <> after)
+
+-- | "A backslash before a newline is a hard line break."
+backslash_newline_is_a_hard_break :: AlphaNumText -> AlphaNumText -> Property
+backslash_newline_is_a_hard_break (AlphaNumText before) (AlphaNumText after) =
+  inlineIs (before <> "\\\n" <> after) [Text before, LineBreak, Text after]
+
+-- | "@...@ becomes an ellipsis."
+ellipsis :: AlphaNumText -> AlphaNumText -> Property
+ellipsis (AlphaNumText before) (AlphaNumText after) =
+  literalIs (before <> "..." <> after) (before <> "\8230" <> after)
+
+-- | "@--@ becomes an en dash."
+en_dash :: AlphaNumText -> AlphaNumText -> Property
+en_dash (AlphaNumText before) (AlphaNumText after) =
+  literalIs (before <> "--" <> after) (before <> "\8211" <> after)
+
+-- | "@---@ becomes an em dash."
+em_dash :: AlphaNumText -> AlphaNumText -> Property
+em_dash (AlphaNumText before) (AlphaNumText after) =
+  literalIs (before <> "---" <> after) (before <> "\8212" <> after)
+
+-- | "Straight quotes are treated as curly quotes", opening after a space.
+smart_quotes :: AlphaNumText -> Property
+smart_quotes (AlphaNumText t) =
+  literalIs ("\"" <> t <> "\"") ("\8220" <> t <> "\8221")
+
+--------------------------------------------------------------------------------
+-- blocks
+--------------------------------------------------------------------------------
+
+-- | Djot has no syntax errors to report, every input is a document.
+all_compile :: AsciiText -> Property
+all_compile (AsciiText input) = monadicIO $ shouldParse djotDocument input
+
+-- | "A heading starts with a sequence of one or more @#@ characters, followed
+-- by whitespace [...] the number of @#@ characters defines the level."
+heading_levels :: HeaderLevel -> AlphaNumText -> Property
+heading_levels (HeaderLevel level) (AlphaNumText t) =
+  parses (T.replicate level "#" <> " " <> t) (Doc [Heading (H {level, text = [Text t]}) mempty])
+
+-- | "A paragraph [...] ends with a blank line or the end of the document."
+paragraphs_split_on_blank_lines :: AlphaNumText -> AlphaNumText -> Property
+paragraphs_split_on_blank_lines (AlphaNumText a) (AlphaNumText b) =
+  parses
+    (a <> "\n\n" <> b)
+    (Doc [Paragraph (P [Text a]) mempty, Paragraph (P [Text b]) mempty])
+
+-- | "The contents of the block quote are parsed as block-level content", so a
+-- quoted line is a paragraph inside the quote rather than bare inlines.
+block_quote_holds_blocks :: AlphaNumText -> Property
+block_quote_holds_blocks (AlphaNumText t) =
+  parses ("> " <> t) (Doc [BlockQuote (Q [Paragraph (P [Text t]) mempty]) mempty])
+
+-- | "A line containing three or more @*@ or @-@ characters, and nothing else
+-- except spaces and tabs, is a thematic break."
+data Break = Break Char Int
+  deriving (Show)
+
+instance Arbitrary Break where
+  arbitrary = Break <$> elements "*-" <*> chooseInt (3, 8)
+  shrink (Break c n) = [Break c n' | n' <- [3 .. n - 1]]
+
+thematic_break :: Break -> Property
+thematic_break (Break c n) =
+  parses (T.replicate n (T.singleton c)) (Doc [HorizontalRule mempty])
+
+-- | "A code block starts with three or more consecutive backticks [...] the
+-- word after the backticks is the language."
+code_block_with_language :: AlphaNumText -> AlphaNumText -> Property
+code_block_with_language (AlphaNumText language) (AlphaNumText code) =
+  parses
+    ("```" <> language <> "\n" <> code <> "\n```")
+    (Doc [Code (C {language = Just language, code = code <> "\n"}) mempty])
+
+code_block_without_language :: AlphaNumText -> Property
+code_block_without_language (AlphaNumText code) =
+  parses
+    ("```\n" <> code <> "\n```")
+    (Doc [Code (C {language = Nothing, code = code <> "\n"}) mempty])
+
+-- | "[...] until a closing fence of at least the same length."
+closing_fence_may_be_longer :: AlphaNumText -> Property
+closing_fence_may_be_longer (AlphaNumText code) =
+  parses
+    ("```\n" <> code <> "\n`````")
+    (Doc [Code (C {language = Nothing, code = code <> "\n"}) mempty])
+
+-- | "A code block with @=FORMAT@ as the language is a raw block."
+raw_block :: AlphaNumText -> AlphaNumText -> Property
+raw_block (AlphaNumText format) (AlphaNumText content) =
+  parses
+    ("```=" <> format <> "\n" <> content <> "\n```")
+    (Doc [RawBlock (RB {format, content = content <> "\n"}) mempty])
+
+-- | "A div starts with three or more consecutive colons [...] the text after
+-- the colons is used as a class name."
+div_block :: AlphaNumText -> AlphaNumText -> Property
+div_block (AlphaNumText cls) (AlphaNumText t) =
+  parses
+    ("::: " <> cls <> "\n" <> t <> "\n:::")
+    (Doc [Container [Paragraph (P [Text t]) mempty] (classOf cls)])
+
+--------------------------------------------------------------------------------
+-- blocks: lists
+--------------------------------------------------------------------------------
+
+-- | "Bullet list markers are @-@, @+@ and @*@."
+newtype Bullet = Bullet Char
+  deriving (Show)
+
+instance Arbitrary Bullet where
+  arbitrary = Bullet <$> elements "-+*"
+  shrink _ = []
+
+bullet_markers :: Bullet -> AlphaNumText -> AlphaNumText -> Property
+bullet_markers (Bullet c) (AlphaNumText a) (AlphaNumText b) =
+  parses
+    (m <> " " <> a <> "\n" <> m <> " " <> b)
+    (Doc [List (L {list_type = Unordered {style = Nothing}, items = [item a, item b]}) mempty])
+  where
+    m = T.singleton c
+
+-- | The ordered marker styles the reference lists: decimal, lower and upper
+-- alpha, lower and upper roman, each with a @.@, @)@ or @(...)@ delimiter.
+data NumberStyle = Decimal | LowerAlpha | UpperAlpha | LowerRoman | UpperRoman
+  deriving (Show, Eq)
+
+data Delim = Period | Paren | Parens
+  deriving (Show, Eq)
+
+data OrderedMarker = OrderedMarker NumberStyle Delim Int
+  deriving (Show)
+
+instance Arbitrary OrderedMarker where
+  arbitrary = do
+    style <- elements [Decimal, LowerAlpha, UpperAlpha, LowerRoman, UpperRoman]
+    delim <- elements [Period, Paren, Parens]
+    start <- startFor style
+    pure $ OrderedMarker style delim start
+  -- only decimal starts form a range worth searching, the others are picked
+  -- from a handful of unambiguous values
+  shrink (OrderedMarker Decimal delim start) = [OrderedMarker Decimal delim s | s <- [1 .. start - 1]]
+  shrink _ = []
+
+-- | A single letter is ambiguous between the alphabetic and roman styles, so
+-- alphabetic starts avoid the roman letters and roman starts avoid the values
+-- whose numeral is a single character.
+startFor :: NumberStyle -> Gen Int
+startFor Decimal = chooseInt (1, 20)
+startFor LowerAlpha = elements alphaStarts
+startFor UpperAlpha = elements alphaStarts
+startFor LowerRoman = elements romanStarts
+startFor UpperRoman = elements romanStarts
+
+alphaStarts :: [Int]
+alphaStarts = [n | n <- [1 .. 25], letter n `notElem` ("ivxlcdm" :: String)]
+  where
+    letter n = toEnum (fromEnum 'a' + n - 1) :: Char
+
+-- ii, iii, iv, vii, viii, ix
+romanStarts :: [Int]
+romanStarts = [2, 3, 4, 7, 8, 9]
+
+numeral :: NumberStyle -> Int -> T.Text
+numeral Decimal n = T.pack (show n)
+numeral LowerAlpha n = T.singleton (toEnum (fromEnum 'a' + n - 1))
+numeral UpperAlpha n = T.singleton (toEnum (fromEnum 'A' + n - 1))
+numeral LowerRoman n = T.toLower (roman n)
+numeral UpperRoman n = roman n
+
+roman :: Int -> T.Text
+roman = go [(1000, "M"), (900, "CM"), (500, "D"), (400, "CD"), (100, "C"), (90, "XC"), (50, "L"), (40, "XL"), (10, "X"), (9, "IX"), (5, "V"), (4, "IV"), (1, "I")]
+  where
+    go [] _ = ""
+    go all_digits@((value, sign) : rest) n
+      | n >= value = sign <> go all_digits (n - value)
+      | otherwise = go rest n
+
+renderMarker :: OrderedMarker -> Int -> T.Text
+renderMarker (OrderedMarker style delim _) n = case delim of
+  Period -> num <> "."
+  Paren -> num <> ")"
+  Parens -> "(" <> num <> ")"
+  where
+    num = numeral style n
+
+styleOf :: NumberStyle -> Maybe T.Text
+styleOf Decimal = Nothing
+styleOf LowerAlpha = Just "a"
+styleOf UpperAlpha = Just "A"
+styleOf LowerRoman = Just "i"
+styleOf UpperRoman = Just "I"
+
+-- | "The start number of an ordered list will be determined by the number of
+-- its first item."
+ordered_markers :: OrderedMarker -> AlphaNumText -> AlphaNumText -> Property
+ordered_markers marker@(OrderedMarker style _ start) (AlphaNumText a) (AlphaNumText b) =
+  parses
+    (renderMarker marker start <> " " <> a <> "\n" <> renderMarker marker (start + 1) <> " " <> b)
+    (Doc [List (L {list_type = Ordered {start_number = Just start, style = styleOf style}, items = [item a, item b]}) mempty])
+
+-- | "A list is tight if there are no blank lines between items"; a tight item's
+-- paragraph is not wrapped.
+tight_list_items_are_unwrapped :: AlphaNumText -> AlphaNumText -> Property
+tight_list_items_are_unwrapped (AlphaNumText a) (AlphaNumText b) =
+  parses
+    ("- " <> a <> "\n- " <> b)
+    (Doc [List (L {list_type = Unordered {style = Nothing}, items = [item a, item b]}) mempty])
+
+-- | A blank line between items makes the list loose, and a loose item's content
+-- stays a paragraph.
+loose_list_items_keep_paragraphs :: AlphaNumText -> AlphaNumText -> Property
+loose_list_items_keep_paragraphs (AlphaNumText a) (AlphaNumText b) =
+  parses
+    ("- " <> a <> "\n\n- " <> b)
+    (Doc [List (L {list_type = Unordered {style = Nothing}, items = [loose a, loose b]}) mempty])
+  where
+    loose t = LI {content = [Paragraph (P [Text t]) mempty]}
+
+-- | "A list item [...] is followed by one or more indented lines", which are
+-- parsed as blocks, so an indented marker starts a nested list.
+nested_list :: AlphaNumText -> AlphaNumText -> Property
+nested_list (AlphaNumText a) (AlphaNumText b) =
+  parses
+    ("- " <> a <> "\n  - " <> b)
+    ( Doc
+        [ List
+            ( L
+                { list_type = Unordered {style = Nothing},
+                  items =
+                    [ LI
+                        { content =
+                            [ Transparent [Text a],
+                              List (L {list_type = Unordered {style = Nothing}, items = [item b]}) mempty
+                            ]
+                        }
+                    ]
+                }
+            )
+            mempty
+        ]
+    )
+
+-- | "A bullet list item that begins with @[ ]@, @[X]@ or @[x]@ followed by a
+-- space is a task list item."
+task_list :: AlphaNumText -> AlphaNumText -> Property
+task_list (AlphaNumText a) (AlphaNumText b) =
+  parses
+    ("- [ ] " <> a <> "\n- [x] " <> b)
+    (Doc [TaskList (TL {items = [task False a, task True b]}) mempty])
+  where
+    task checked t = Ta {checked, content = [Transparent [Text t]]}
+
+-- | "@:@ [...] the first line is the term, the following blocks the
+-- definition."
+definition_list :: AlphaNumText -> AlphaNumText -> Property
+definition_list (AlphaNumText term) (AlphaNumText def) =
+  parses
+    (": " <> term <> "\n\n  " <> def)
+    (Doc [DescriptionList (DL {items = [Def {defTitle = [Text term], defContent = [Paragraph (P [Text def]) mempty]}]}) mempty])
+
+--------------------------------------------------------------------------------
+-- blocks: tables
+--------------------------------------------------------------------------------
+
+-- | "@:-@ left aligned, @-:@ right aligned, @:-:@ centered, @-@ default."
+newtype Align = Align Alignment
+  deriving (Show)
+
+instance Arbitrary Align where
+  arbitrary = Align <$> elements [AlignDefault, AlignLeft, AlignRight, AlignCenter]
+  shrink _ = []
+
+separatorFor :: Alignment -> T.Text
+separatorFor AlignDefault = "---"
+separatorFor AlignLeft = ":--"
+separatorFor AlignRight = "--:"
+separatorFor AlignCenter = ":-:"
+
+-- | "The row before the separator line is treated as a header [...] cell
+-- contents are parsed as inline content."
+table :: Align -> Align -> AlphaNumText -> AlphaNumText -> AlphaNumText -> AlphaNumText -> Property
+table (Align left) (Align right) (AlphaNumText h1) (AlphaNumText h2) (AlphaNumText c1) (AlphaNumText c2) =
+  parses
+    ( T.concat
+        [ "| " <> h1 <> " | " <> h2 <> " |\n",
+          "| " <> separatorFor left <> " | " <> separatorFor right <> " |\n",
+          "| " <> c1 <> " | " <> c2 <> " |"
+        ]
+    )
+    ( Doc
+        [ Table
+            ( T
+                { tableCaption = Nothing,
+                  tableHead = Just (row h1 h2),
+                  tableBody = [row c1 c2],
+                  columnAlignments = Just [left, right]
+                }
+            )
+            mempty
+        ]
+    )
+  where
+    row a b = TR [TC [Text a], TC [Text b]]
+
+-- | "@^ caption text@ directly after the table is its caption."
+table_caption :: AlphaNumText -> AlphaNumText -> Property
+table_caption (AlphaNumText cell) (AlphaNumText caption) =
+  parses
+    ("| " <> cell <> " |\n^ " <> caption)
+    ( Doc
+        [ Table
+            ( T
+                { tableCaption = Just [Text caption],
+                  tableHead = Nothing,
+                  tableBody = [TR [TC [Text cell]]],
+                  columnAlignments = Nothing
+                }
+            )
+            mempty
+        ]
+    )
+
+--------------------------------------------------------------------------------
+-- blocks: definitions and attributes
+--------------------------------------------------------------------------------
+
+-- | "A footnote consists of a footnote reference followed by a colon followed
+-- by the contents of the note", parsed as block-level content.
+footnote_definition :: AlphaNumText -> AlphaNumText -> Property
+footnote_definition (AlphaNumText label) (AlphaNumText content) =
+  parses
+    ("[^" <> label <> "]: " <> content)
+    (Doc [Footnote (F {label, content = [Paragraph (P [Text content]) mempty]}) mempty])
+
+-- | "@[label]: url@."
+reference_definition :: AlphaNumText -> UrlText -> Property
+reference_definition (AlphaNumText label) (UrlText link) =
+  parses ("[" <> label <> "]: " <> link) (Doc [ReferenceDefinition (RD {label, link})])
+
+-- | "Attributes on a line immediately before a block attach to that block."
+block_attributes :: AlphaNumText -> AlphaNumText -> AlphaNumText -> Property
+block_attributes (AlphaNumText ident) (AlphaNumText cls) (AlphaNumText t) =
+  parses
+    ("{#" <> ident <> " ." <> cls <> "}\n" <> t)
+    (Doc [Paragraph (P [Text t]) (Attrs {attrId = Just ident, attrClasses = [cls], attrKV = []})])
+
+--------------------------------------------------------------------------------
+-- whole documents
+--------------------------------------------------------------------------------
+
+-- | The generalisation of the block tests: a generated document, written out in
+-- djot's spelling, 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 djotDocument source (expected djotSyntax spec)
+  where
+    source = render djotSyntax spec

tests/Main.hs

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

tests/Markdown/Parse.hs

@@ -1,338 +1,229 @@
 {-# LANGUAGE OverloadedStrings #-}
 
-module Main where
+module Markdown.Parse (tests) 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.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.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)
 
-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)
-          -- ("",),
+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
     ]
-  if cond
-    then exitSuccess
-    else exitFailure
 
--- 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
+hashes :: Int -> T.Text
+hashes level = T.replicate level "#"
 
-all_compiles :: Property
-all_compiles = property $ do
-  xs <- forAll $ Gen.text (Range.linear 0 100) Gen.ascii
-  parsed <- generic_parse xs
-  case parsed of
-    Nothing -> fail $ "Hit Timeout"
-    (Just (Right _)) -> success
-    (Just (Left e)) -> fail $ errorBundlePretty e
+all_compiles :: AsciiText -> Property
+all_compiles (AsciiText input) = monadicIO $ shouldParse markdownDocument input
 
-block_html_compile_edgecase :: Property
-block_html_compile_edgecase = property $ do
-  let gen = forAll $ Gen.text (Range.linear 0 10) Gen.alphaNum
-  tagName <- gen
-  misc1 <- gen
-  misc2 <- gen
-  parsed <- generic_parse $ (T.concat ["<", tagName, ">", misc1, "</", tagName, "> ", misc2])
-  case parsed of
-    Nothing -> fail $ "Hit Timeout"
-    (Just (Right _)) -> success
-    (Just (Left e)) -> fail $ errorBundlePretty e
+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 :: 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
-
-  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
-
-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
-
-  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
-
-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
-
-  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
-
-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
-  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
-
-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
-  let input = "```" <> language <> "\n" <> code <> "```"
-  parsed <- generic_parse input
-
-  case parsed of
-    Nothing -> fail $ "Hit Timeout"
-    -- we're just testing for hanging
-    (Just (Right _)) -> success
-    (Just (Left e)) -> fail $ errorBundlePretty e
-
-two_blockquotes :: Property
-two_blockquotes = property $ do
-  let text_gen = forAll $ Gen.text (Range.linear 1 10) Gen.alpha
-  text_1 <- text_gen
-  text_2 <- text_gen
-  let input = "> " <> text_1 <> "\n\n> " <> text_2
-
-  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
-
-unordered_list :: Property
-unordered_list = property $ do
-  let text_gen = forAll $ Gen.text (Range.linear 1 10) Gen.alpha
-  text_1 <- text_gen
-  text_2 <- text_gen
-  let input = "- " <> text_1 <> "\n- " <> text_2
-
-  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
-
-header_after_unordered_list :: Property
-header_after_unordered_list = property $ do
-  let text_gen = forAll $ Gen.text (Range.linear 1 10) Gen.alpha
-  bullet_text <- text_gen
-  header_text <- text_gen
-  header_level <- forAll $ Gen.int (Range.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
-
-ordered_list :: Property
-ordered_list = property $ do
-  let text_gen = forAll $ Gen.text (Range.linear 1 10) Gen.alpha
-  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 -> 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
-
-multiple_ordered_lists :: Property
-multiple_ordered_lists = property $ do
-  let text_gen = forAll $ Gen.text (Range.linear 1 10) Gen.alpha
-  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 -> fail $ "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}]})
+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
         ]
-              )
-          )
-      ) -> success
-    (Just (Right tree)) -> fail $ "Incorrect syntax tree: " <> show tree
-    (Just (Left e)) -> fail $ 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
-  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"
-    ( 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}]})}]})
+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]]}
+            ]
         ]
-              )
-          )
-      ) -> success
-    (Just (Right tree)) -> fail $ "Incorrect syntax tree: " <> show tree
-    (Just (Left e)) -> fail $ 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
-  item_1 <- text_gen
-  item_2 <- text_gen
-  item_3 <- text_gen
-  let input = "- " <> item_1 <> "\n    - " <> item_2 <> "\n- " <> item_3
+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
+            ]
+        ]
 
-  parsed <- generic_parse input
-  case parsed of
-    Nothing -> fail $ "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}]})
+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}
                 ]
             )
-          )
-      ) -> success
-    (Just (Right tree)) -> fail $ "Incorrect syntax tree: " <> show tree
-    (Just (Left e)) -> fail $ 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 <- text_gen
-  header_level <- forAll $ Gen.int (Range.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
-
-  case parsed of
-    Nothing -> fail $ "Hit Timeout"
-    ( Just
-        ( Right
-            ( Doc
-                [ Heading (H {level = header_level, text = header}),
-                  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}
+            mempty
         ]
-                        }
-                      )
-                  ]
-              )
-          )
-      ) -> success
-    (Just (Right tree)) -> fail $ "Incorrect syntax tree: " <> show tree
-    (Just (Left e)) -> fail $ errorBundlePretty e
 
-greedy_plain_text :: Property
-greedy_plain_text = property $ do
-  let text_gen = forAll $ Gen.text (Range.linear 1 10) Gen.alphaNum
-  pretext <- text_gen
-  shown <- text_gen
-  link <- text_gen
+-- | 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]
 
-  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
+-- | 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 markdownSyntax spec)
+  where
+    source = render markdownSyntax spec

tests/Test/Gen.hs

@@ -0,0 +1,229 @@
+{-# 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 (..),
+    VerbatimText (..),
+    UrlText (..),
+    HeaderLevel (..),
+
+    -- * escaping
+    Escaper (..),
+    backslashEscaper,
+    unescapable,
+    markdownEscaper,
+    djotEscaper,
+    escapeWith,
+    EscapedText (..),
+    escapedText,
+    MarkdownText (..),
+    DjotText (..),
+  )
+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
+
+-- | Content for a verbatim span. Djot says verbatim content is literal, so this
+-- ranges over printable ascii rather than words; backticks are excluded because
+-- they would close the span, and the ends are kept non blank because a space
+-- next to a delimiter is subject to a stripping rule of its own.
+newtype VerbatimText = VerbatimText Text
+  deriving (Show)
+
+instance Arbitrary VerbatimText where
+  arbitrary = VerbatimText <$> (textOf verbatimChar 1 20 `suchThat` wellFormed)
+    where
+      verbatimChar = elements $ filter (/= '`') [' ' .. '~']
+      wellFormed t = not (T.null t) && T.head t /= ' ' && T.last t /= ' '
+  shrink (VerbatimText t) =
+    VerbatimText <$> shrinkTextWith (\s -> not (T.null s) && T.last s /= ' ') t
+
+-- | Something that can sit inside @(...)@ as a link destination: no spaces, no
+-- closing paren, no newline.
+newtype UrlText = UrlText Text
+  deriving (Show)
+
+instance Arbitrary UrlText where
+  arbitrary = UrlText <$> textOf urlChar 1 20
+    where
+      urlChar = elements $ ['a' .. 'z'] <> ['A' .. 'Z'] <> ['0' .. '9'] <> "./:-_~"
+  shrink (UrlText t) = UrlText <$> 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 "`*[~_!<"
+
+-- | Djot's inline specials. The syntax reference says a backslash escapes any
+-- ASCII punctuation, and every character here is ASCII punctuation, so all of
+-- them are representable in plain text rather than having to be avoided.
+--
+-- The quote characters are deliberately absent. They are not markup, they are
+-- input to the smart punctuation pass, and what an escaped quote should turn
+-- into is a separate question from whether escaping works at all.
+djotEscaper :: Escaper
+djotEscaper = backslashEscaper "\\`*_^~[]{}<>$:!-.=+"
+
+-- | 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
+
+-- | The same for Djot, where the escaper does have an escape mechanism, so the
+-- generated literals contain the special characters and the source form is the
+-- backslash escaped version of them.
+newtype DjotText = DjotText EscapedText
+  deriving (Show)
+
+instance Arbitrary DjotText where
+  arbitrary = DjotText <$> escapedText djotEscaper alphaNumChar 1 20
+  shrink (DjotText t) = DjotText . escaped djotEscaper <$> shrinkTextWith (not . T.null) t.literal

tests/Test/Gen/Document.hs

@@ -0,0 +1,351 @@
+{-# 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,
+    djotSyntax,
+    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 = separate . merge
+  where
+    merge (PlainS a : PlainS b : rest) = merge (PlainS (a <> b) : rest)
+    merge (x : rest) = x : merge rest
+    merge [] = []
+    -- two markup elements written back to back are ambiguous whenever they
+    -- share a delimiter character: `a``b` is a verbatim span that failed to
+    -- close, not two spans, and the reference says as much ("opening and
+    -- closing backticks must match in length"). a space between them costs the
+    -- test nothing and makes every generated run mean one thing.
+    separate (a : b : rest)
+      | not (isPlain a) && not (isPlain b) = a : PlainS " " : separate (b : rest)
+    separate (x : rest) = x : separate rest
+    separate [] = []
+    isPlain (PlainS _) = True
+    isPlain _ = False
+
+-- * generation
+
+instance Arbitrary DocSpec where
+  arbitrary = sized $ \size -> do
+    count <- chooseInt (1, 1 + min 3 (size `div` 8))
+    DocSpec . mkBlocks <$> vectorOf count blockSpec
+
+  -- an empty document is legitimate, `document` is a `many`
+  shrink (DocSpec blocks) = DocSpec . mkBlocks <$> shrinkList shrinkBlock blocks
+
+-- | In djot a blank line between two items only makes the list loose, so two
+-- lists written one after the other are a single list rather than two blocks.
+-- A document therefore never places two lists next to each other; dropping the
+-- second is the normalisation that survives shrinking, inserting a separator
+-- between them would grow the value the shrinker just made smaller.
+mkBlocks :: [BlockSpec] -> [BlockSpec]
+mkBlocks (first@(ListS _ _) : ListS _ _ : rest) = mkBlocks (first : rest)
+mkBlocks (block : rest) = block : mkBlocks rest
+mkBlocks [] = []
+
+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, and the two places where the
+-- two syntaxes disagree about what the result should be. The rest of the
+-- expectations are shared.
+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,
+    -- | how the single line of a quote appears inside the BlockQuote. Djot
+    -- parses a quote's contents as blocks, so it is a Paragraph; the Markdown
+    -- parser collects inlines and wraps them in a Transparent.
+    quoteContent :: [InlineText] -> Element,
+    -- | djot reads the start number and style off the first marker, the
+    -- Markdown parser does not record either
+    listTypeFor :: Marker -> ListType
+  }
+
+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",
+      quoteContent = Transparent,
+      listTypeFor = \case
+        Bullet _ -> Unordered {style = Nothing}
+        Numbered _ -> Ordered {start_number = Nothing, style = Nothing}
+    }
+
+-- | Djot. Strong is @*@ and emphasis @_@, delete has to be written in its
+-- braced form, and the rest lines up with the markdown spelling.
+djotSyntax :: Syntax
+djotSyntax =
+  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",
+      quoteContent = \content -> Paragraph (P content) mempty,
+      listTypeFor = \case
+        Bullet _ -> Unordered {style = Nothing}
+        -- the generator numbers items from one, and a decimal marker carries no
+        -- style
+        Numbered _ -> Ordered {start_number = Just 1, style = Nothing}
+    }
+
+marked :: Marker -> Int -> Text
+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 :: Syntax -> DocSpec -> Document
+expected syntax (DocSpec blocks) = Doc $ map (expectedBlock syntax) blocks
+
+expectedBlock :: Syntax -> BlockSpec -> Element
+expectedBlock syntax = \case
+  ParagraphS run -> Paragraph (P (expectedRun run)) mempty
+  HeadingS level run -> Heading (H {level, text = expectedRun run}) mempty
+  QuoteS run -> BlockQuote (Q [syntax.quoteContent (expectedRun run)]) mempty
+  ListS marker items -> List (expectedList syntax marker items) mempty
+
+expectedList :: Syntax -> Marker -> [ItemSpec] -> List
+expectedList syntax marker items =
+  L {list_type = syntax.listTypeFor marker, items = map (expectedItem syntax) items}
+
+-- | A tight item's paragraph is unwrapped by both parsers, so its content is a
+-- Transparent regardless of syntax.
+expectedItem :: Syntax -> ItemSpec -> ListItem
+expectedItem syntax (ItemS run nested) = LI {content = Transparent (expectedRun run) : child}
+  where
+    child = case nested of
+      Nothing -> []
+      Just (marker, runs) ->
+        [List (expectedList syntax 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,98 @@
+{-# 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,
+    djotDocument,
+    shouldParseTo,
+    shouldParse,
+    succeed,
+    failWith,
+  )
+where
+
+import Control.Exception (evaluate)
+import Data.Functor.Identity (Identity)
+import Data.Text (Text)
+import Data.Void (Void)
+import qualified Djot
+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
+
+djotDocument :: DocumentParser
+djotDocument = Djot.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