.gitignore

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

psb.cabal

@@ -30,14 +30,13 @@ 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 NamedFieldPuns DuplicateRecordFields DisambiguateRecordFields FlexibleInstances
+    default-extensions: ApplicativeDo DataKinds NamedFieldPuns DerivingVia LambdaCase TypeApplications DeriveGeneric OverloadedRecordDot OverloadedRecordUpdate NamedFieldPuns DuplicateRecordFields DisambiguateRecordFields FlexibleInstances
 
-test-suite tests
+test-suite test-markdown-parse
     hs-source-dirs: tests
     type: exitcode-stdio-1.0
-    main-is: Main.hs
+    main-is: Markdown/Parse.hs
-    other-modules: Test.Gen, Test.Gen.Document, Test.Harness, Markdown.Parse, Djot.Parse
+    build-depends: base, text, megaparsec, transformers, hedgehog, time, psb
-    build-depends: base, text, megaparsec, transformers, QuickCheck, tasty, tasty-quickcheck, time, psb
     
     default-extensions: ApplicativeDo DataKinds NamedFieldPuns DerivingVia LambdaCase TypeApplications DeriveGeneric OverloadedRecordDot NamedFieldPuns DuplicateRecordFields DisambiguateRecordFields FlexibleInstances
     default-language: Haskell2010

src/IR.hs

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

src/Markdown.hs

@@ -45,15 +45,7 @@ element =
       try htmlBlock <?> "HTML Block",
       paragraphBlock <?> "Paragarph"
     ]
-    -- a block is normally followed by a blank line or the end of input, but a
+    <* blockEnding
-    -- 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)
@@ -145,7 +137,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 Nothing else Just language'
+  let language = if language' == "" then Just language' else Nothing
   pure $ Code (C {language, code}) mempty
 
 blockquoteBlock :: (Logger m, Characters s) => Parser s m Element
@@ -178,11 +170,7 @@ listBlock list_type prefix child_parser_factory nest_level = do
 
       optional ((notFollowedBy blockEnding) *> lineEnding)
 
-      -- the try is load bearing, optional only recovers from a failure that
+      child <- optional $ child_parser_factory $ nest_level + 1
-      -- 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

@@ -1,706 +0,0 @@
-{-# 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

@@ -1,14 +0,0 @@
-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,229 +1,338 @@
 {-# LANGUAGE OverloadedStrings #-}
 
-module Markdown.Parse (tests) where
+module Main where
 
+import Control.Exception (evaluate)
+import Control.Monad.Trans.Class (MonadTrans (lift))
+import Data.Either (isRight)
+import Data.Functor.Identity (Identity (Identity))
+import Data.String (IsString)
+import Data.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 Test.Gen (AlphaNumText (..), AlphaText (..), AsciiText (..), EscapedText (..), HeaderLevel (..), MarkdownText (..))
+import Markdown
-import Test.Gen.Document (DocSpec, expected, markdownSyntax, render)
+import qualified Markdown
-import Test.Harness (markdownDocument, shouldParse, shouldParseTo)
+import System.Exit (exitFailure, exitSuccess)
-import Test.QuickCheck (Property, counterexample)
+import System.Timeout (timeout)
-import Test.QuickCheck.Monadic (monadicIO)
+import Text.Megaparsec
-import Test.Tasty (TestTree, testGroup)
-import Test.Tasty.QuickCheck (testProperty)
 
-tests :: TestTree
+main :: IO ()
-tests =
+main = do
-  testGroup
+  cond <-
-    "Markdown"
+    checkParallel $
-    [ testProperty "all_compile" all_compiles,
+      Group
-      testProperty "block_html_compile_edgecase" block_html_compile_edgecase,
+        "Parse Tests"
-      testProperty "header_and_paragraph" header_and_paragraph,
+        [ ("all_compile", all_compiles),
-      testProperty "paragraph_and_header_and_paragraph" paragraph_and_header_and_paragraph,
+          ("block_html_compile_edgecase", block_html_compile_edgecase),
-      testProperty "bold_and_header_and_paragraph" bold_and_header_and_paragraph,
+          ("header_and_paragraph", header_and_paragraph),
-      testProperty "code_block" code_block,
+          ("paragraph_and_header_and_paragraph", paragraph_and_header_and_paragraph),
-      testProperty "code_block_hanging" code_block_hanging,
+          ("bold_and_header_and_paragraph", bold_and_header_and_paragraph),
-      testProperty "two_blockquotes" two_blockquotes,
+          ("code_block", code_block),
-      testProperty "unordered_list" unordered_list,
+          ("code_block_hanging", code_block_hanging),
-      testProperty "header_after_unordered_list" header_after_unordered_list,
+          ("two_blockquotes", two_blockquotes),
-      testProperty "ordered_list" ordered_list,
+          ("unordered_list", unordered_list),
-      testProperty "multiple_ordered_lists" multiple_ordered_lists,
+          ("header_after_unordered_list", header_after_unordered_list),
-      testProperty "header_then_ordered_list" header_then_ordered_list,
+          ("ordered_list", ordered_list),
-      testProperty "simple_nested_ordered_list" simple_nested_ordered_list,
+          ("multiple_ordered_lists", multiple_ordered_lists),
-      testProperty "nested_unordered_list" nested_unordered_list,
+          ("header_then_ordered_list", header_then_ordered_list),
-      testProperty "greedy_plain_text" greedy_plain_text,
+          ("simple_nested_ordered_list", simple_nested_ordered_list),
-      testProperty "plain_text_is_literal" plain_text_is_literal,
+          ("nested_unordered_list", nested_unordered_list),
-      testProperty "document_round_trip" document_round_trip
+          ("greedy_plain_text", greedy_plain_text)
+          -- ("",),
         ]
+  if cond
+    then exitSuccess
+    else exitFailure
 
-hashes :: Int -> T.Text
+-- timeout of 1 second, all of these tests should be completely clear of that, if they run longer they should fail
-hashes level = T.replicate level "#"
+generic_parse inp = lift $ timeout 1000000 $ evaluate $ parse (Markdown.document :: ParsecT Void Text Identity IR.Document) "test_input" inp
 
-all_compiles :: AsciiText -> Property
+all_compiles :: Property
-all_compiles (AsciiText input) = monadicIO $ shouldParse markdownDocument input
+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
 
-block_html_compile_edgecase :: AlphaNumText -> AlphaNumText -> AlphaNumText -> Property
+block_html_compile_edgecase :: Property
-block_html_compile_edgecase (AlphaNumText tag_name) (AlphaNumText misc1) (AlphaNumText misc2) =
+block_html_compile_edgecase = property $ do
-  monadicIO $ shouldParse markdownDocument input
+  let gen = forAll $ Gen.text (Range.linear 0 10) Gen.alphaNum
-  where
+  tagName <- gen
-    input = T.concat ["<", tag_name, ">", misc1, "</", tag_name, "> ", misc2]
+  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
 
-header_and_paragraph :: AlphaText -> HeaderLevel -> AlphaText -> Property
+header_and_paragraph :: Property
-header_and_paragraph (AlphaText header_text) (HeaderLevel level) (AlphaText paragraph_text) =
+header_and_paragraph = property $ do
-  monadicIO $ shouldParseTo markdownDocument input tree
+  header_text <- forAll $ Gen.text (Range.linear 1 10) Gen.alpha
-  where
+  header_level <- forAll $ Gen.int (Range.linear 1 6)
-    input = hashes level <> header_text <> "\n\n" <> paragraph_text
+  paragraph_text <- forAll $ Gen.text (Range.linear 1 10) Gen.alpha
-    tree =
+
-      Doc
+  let input = (T.pack $ take header_level $ repeat '#') <> header_text <> "\n\n" <> paragraph_text
-        [ Heading (H {level, text = [Text header_text]}) mempty,
+
-          Paragraph (P [Text paragraph_text]) mempty
+  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}]})
                   ]
+              )
+          )
+      ) -> success
+    (Just (Right tree)) -> fail $ "Incorrect syntax tree: " <> show tree
+    (Just (Left e)) -> fail $ errorBundlePretty e
 
-paragraph_and_header_and_paragraph :: AlphaText -> AlphaText -> HeaderLevel -> AlphaText -> Property
+simple_nested_ordered_list :: Property
-paragraph_and_header_and_paragraph (AlphaText paragraph1_text) (AlphaText header_text) (HeaderLevel level) (AlphaText paragraph2_text) =
+simple_nested_ordered_list = property $ do
-  monadicIO $ shouldParseTo markdownDocument input tree
+  let text_gen = forAll $ Gen.text (Range.linear 1 10) Gen.alpha
-  where
+  item_1 <- text_gen
-    input = paragraph1_text <> "\n\n" <> hashes level <> header_text <> "\n\n" <> paragraph2_text
+  item_2 <- text_gen
-    tree =
+  let input = "1) " <> item_1 <> "\n    1) " <> item_2
-      Doc
+
-        [ Paragraph (P [Text paragraph1_text]) mempty,
+  parsed <- generic_parse input
-          Heading (H {level, text = [Text header_text]}) mempty,
+  case parsed of
-          Paragraph (P [Text paragraph2_text]) mempty
+    Nothing -> fail $ "Hit Timeout"
-        ]
+    ( Just
-
+        ( Right
-bold_and_header_and_paragraph :: AlphaText -> AlphaText -> HeaderLevel -> AlphaText -> Property
+            ( Doc
-bold_and_header_and_paragraph (AlphaText bold_text) (AlphaText header_text) (HeaderLevel level) (AlphaText paragraph_text) =
+                [ 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}]})}]})
-  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 :: AlphaText -> AlphaText -> AlphaText -> Property
+nested_unordered_list :: Property
-nested_unordered_list (AlphaText item_1) (AlphaText item_2) (AlphaText item_3) =
+nested_unordered_list = property $ do
-  monadicIO $ shouldParseTo markdownDocument input tree
+  let text_gen = forAll $ Gen.text (Range.linear 1 10) Gen.alpha
-  where
+  item_1 <- text_gen
-    input = "- " <> item_1 <> "\n    - " <> item_2 <> "\n- " <> item_3
+  item_2 <- text_gen
-    tree =
+  item_3 <- text_gen
-      Doc
+  let input = "- " <> item_1 <> "\n    - " <> item_2 <> "\n- " <> item_3
-        [ unorderedList
-            [ LI {content = [Transparent [Text item_1], unorderedList [item item_2]]},
-              item item_3
-            ]
-        ]
 
-greedy_plain_text :: AlphaNumText -> AlphaNumText -> AlphaNumText -> Property
+  parsed <- generic_parse input
-greedy_plain_text (AlphaNumText pretext) (AlphaNumText shown) (AlphaNumText url) =
+  case parsed of
-  monadicIO $ shouldParseTo markdownDocument input tree
+    Nothing -> fail $ "Hit Timeout"
-  where
+    ( Just
-    input = T.concat [pretext, "[", shown, "]", "(", url, ")"]
+        ( Right
-    tree =
+            ( Doc
-      Doc
+                [ List (L {list_type = Unordered, items = [LI {content = [Text item_1], child = Just (L {list_type = Unordered, items = [LI {content = [Text item_2], child = Nothing}]})}, LI {content = [Text item_3], child = Nothing}]})
-        [ Paragraph
-            ( P
-                [ Text pretext,
-                  Link {linkText = [Text shown], url, title = Nothing, misc_attrs = mempty}
                   ]
               )
-            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}
                               ]
+                        }
+                      )
+                  ]
+              )
+          )
+      ) -> success
+    (Just (Right tree)) -> fail $ "Incorrect syntax tree: " <> show tree
+    (Just (Left e)) -> fail $ errorBundlePretty e
 
--- | Text written in a form the syntax says means that text has to come back
+greedy_plain_text :: Property
--- out as exactly that text, in one piece.
+greedy_plain_text = property $ do
-plain_text_is_literal :: MarkdownText -> Property
+  let text_gen = forAll $ Gen.text (Range.linear 1 10) Gen.alphaNum
-plain_text_is_literal (MarkdownText source) =
+  pretext <- text_gen
-  monadicIO $ shouldParseTo markdownDocument source.rendered tree
+  shown <- text_gen
-  where
+  link <- text_gen
-    tree = Doc [Paragraph (P [Text source.literal]) mempty]
 
--- | The generalisation of every test above it: a generated document, rendered
+  parsed <- generic_parse $ T.concat [pretext, "[", shown, "]", "(", link, ")"]
--- as markdown, has to parse back to the document it was generated from.
+
-document_round_trip :: DocSpec -> Property
+  case parsed of
-document_round_trip spec =
+    Nothing -> fail $ "Hit Timeout"
-  counterexample (T.unpack source) $
+    (Just (Right (Doc [Paragraph (P [Text (pretext), Link {linkText = [Text shown], url = link, title = Nothing}])]))) -> success
-    monadicIO $
+    (Just (Right tree)) -> fail $ "Incorrect syntax tree: " <> show tree
-      shouldParseTo markdownDocument source (expected markdownSyntax spec)
+    (Just (Left e)) -> fail $ errorBundlePretty e
-  where
-    source = render markdownSyntax spec

tests/Test/Gen.hs

@@ -1,229 +0,0 @@
-{-# 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

@@ -1,351 +0,0 @@
-{-# 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

@@ -1,98 +0,0 @@
-{-# 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