{-# 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