psb/tests/Markdown/Parse.hs

{-# LANGUAGE OverloadedStrings #-}

module Markdown.Parse (tests) where

import qualified Data.Text as T
import IR
import Test.Gen (AlphaNumText (..), AlphaText (..), AsciiText (..), EscapedText (..), HeaderLevel (..), MarkdownText (..))
import Test.Gen.Document (DocSpec, expected, markdownSyntax, render)
import Test.Harness (markdownDocument, shouldParse, shouldParseTo)
import Test.QuickCheck (Property, counterexample)
import Test.QuickCheck.Monadic (monadicIO)
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.QuickCheck (testProperty)

tests :: TestTree
tests =
  testGroup
    "Markdown"
    [ testProperty "all_compile" all_compiles,
      testProperty "block_html_compile_edgecase" block_html_compile_edgecase,
      testProperty "header_and_paragraph" header_and_paragraph,
      testProperty "paragraph_and_header_and_paragraph" paragraph_and_header_and_paragraph,
      testProperty "bold_and_header_and_paragraph" bold_and_header_and_paragraph,
      testProperty "code_block" code_block,
      testProperty "code_block_hanging" code_block_hanging,
      testProperty "two_blockquotes" two_blockquotes,
      testProperty "unordered_list" unordered_list,
      testProperty "header_after_unordered_list" header_after_unordered_list,
      testProperty "ordered_list" ordered_list,
      testProperty "multiple_ordered_lists" multiple_ordered_lists,
      testProperty "header_then_ordered_list" header_then_ordered_list,
      testProperty "simple_nested_ordered_list" simple_nested_ordered_list,
      testProperty "nested_unordered_list" nested_unordered_list,
      testProperty "greedy_plain_text" greedy_plain_text,
      testProperty "plain_text_is_literal" plain_text_is_literal,
      testProperty "document_round_trip" document_round_trip
    ]

hashes :: Int -> T.Text
hashes level = T.replicate level "#"

all_compiles :: AsciiText -> Property
all_compiles (AsciiText input) = monadicIO $ shouldParse markdownDocument input

block_html_compile_edgecase :: AlphaNumText -> AlphaNumText -> AlphaNumText -> Property
block_html_compile_edgecase (AlphaNumText tag_name) (AlphaNumText misc1) (AlphaNumText misc2) =
  monadicIO $ shouldParse markdownDocument input
  where
    input = T.concat ["<", tag_name, ">", misc1, "</", tag_name, "> ", misc2]

header_and_paragraph :: AlphaText -> HeaderLevel -> AlphaText -> Property
header_and_paragraph (AlphaText header_text) (HeaderLevel level) (AlphaText paragraph_text) =
  monadicIO $ shouldParseTo markdownDocument input tree
  where
    input = hashes level <> header_text <> "\n\n" <> paragraph_text
    tree =
      Doc
        [ Heading (H {level, text = [Text header_text]}) mempty,
          Paragraph (P [Text paragraph_text]) mempty
        ]

paragraph_and_header_and_paragraph :: AlphaText -> AlphaText -> HeaderLevel -> AlphaText -> Property
paragraph_and_header_and_paragraph (AlphaText paragraph1_text) (AlphaText header_text) (HeaderLevel level) (AlphaText paragraph2_text) =
  monadicIO $ shouldParseTo markdownDocument input tree
  where
    input = paragraph1_text <> "\n\n" <> hashes level <> header_text <> "\n\n" <> paragraph2_text
    tree =
      Doc
        [ Paragraph (P [Text paragraph1_text]) mempty,
          Heading (H {level, text = [Text header_text]}) mempty,
          Paragraph (P [Text paragraph2_text]) mempty
        ]

bold_and_header_and_paragraph :: AlphaText -> AlphaText -> HeaderLevel -> AlphaText -> Property
bold_and_header_and_paragraph (AlphaText bold_text) (AlphaText header_text) (HeaderLevel level) (AlphaText paragraph_text) =
  monadicIO $ shouldParseTo markdownDocument input tree
  where
    input = "**" <> bold_text <> "**\n\n" <> hashes level <> header_text <> "\n\n" <> paragraph_text
    tree =
      Doc
        [ Paragraph (P [Bold [Text bold_text] mempty]) mempty,
          Heading (H {level, text = [Text header_text]}) mempty,
          Paragraph (P [Text paragraph_text]) mempty
        ]

code_block :: AlphaText -> AlphaText -> Property
code_block (AlphaText language) (AlphaText code) =
  monadicIO $ shouldParseTo markdownDocument input tree
  where
    input = "```" <> language <> "\n" <> code <> "\n```"
    -- the newline after the info string ends it, the one before the closing
    -- fence is part of the code
    tree = Doc [Code (C {language = Just language, code = code <> "\n"}) mempty]

code_block_hanging :: AlphaText -> AlphaText -> Property
code_block_hanging (AlphaText language) (AlphaText code) =
  -- a fence whose closing ``` is not on a line of its own, we're only testing
  -- that the parser terminates
  monadicIO $ shouldParse markdownDocument ("```" <> language <> "\n" <> code <> "```")

two_blockquotes :: AlphaText -> AlphaText -> Property
two_blockquotes (AlphaText text_1) (AlphaText text_2) =
  monadicIO $ shouldParseTo markdownDocument input tree
  where
    input = "> " <> text_1 <> "\n\n> " <> text_2
    tree =
      Doc
        [ BlockQuote (Q [Transparent [Text text_1]]) mempty,
          BlockQuote (Q [Transparent [Text text_2]]) mempty
        ]

item :: T.Text -> ListItem
item content = LI {content = [Transparent [Text content]]}

unorderedList :: [ListItem] -> Element
unorderedList items = List (L {list_type = Unordered {style = Nothing}, items}) mempty

orderedList :: [ListItem] -> Element
orderedList items = List (L {list_type = Ordered {start_number = Nothing, style = Nothing}, items}) mempty

unordered_list :: AlphaText -> AlphaText -> Property
unordered_list (AlphaText text_1) (AlphaText text_2) =
  monadicIO $ shouldParseTo markdownDocument input tree
  where
    input = "- " <> text_1 <> "\n- " <> text_2
    tree = Doc [unorderedList [item text_1, item text_2]]

header_after_unordered_list :: AlphaText -> AlphaText -> HeaderLevel -> Property
header_after_unordered_list (AlphaText bullet_text) (AlphaText header_text) (HeaderLevel level) =
  monadicIO $ shouldParseTo markdownDocument input tree
  where
    input = "- " <> bullet_text <> "\n\n" <> hashes level <> header_text
    tree =
      Doc
        [ unorderedList [item bullet_text],
          Heading (H {level, text = [Text header_text]}) mempty
        ]

ordered_list :: AlphaText -> AlphaText -> AlphaText -> Property
ordered_list (AlphaText item_1) (AlphaText item_2) (AlphaText item_3) =
  monadicIO $ shouldParseTo markdownDocument input tree
  where
    input = "1. " <> item_1 <> "\n2. " <> item_2 <> "\n3. " <> item_3
    tree = Doc [orderedList [item item_1, item item_2, item item_3]]

multiple_ordered_lists :: AlphaText -> AlphaText -> AlphaText -> Property
multiple_ordered_lists (AlphaText item_1) (AlphaText item_2) (AlphaText item_3) =
  monadicIO $ shouldParseTo markdownDocument input tree
  where
    input = "1. " <> item_1 <> "\n\n2. " <> item_2 <> "\n\n3. " <> item_3
    tree =
      Doc
        [ orderedList [item item_1],
          orderedList [item item_2],
          orderedList [item item_3]
        ]

header_then_ordered_list :: AlphaText -> HeaderLevel -> AlphaText -> AlphaText -> AlphaText -> Property
header_then_ordered_list (AlphaText header_text) (HeaderLevel level) (AlphaText item_1) (AlphaText item_2) (AlphaText item_3) =
  monadicIO $ shouldParseTo markdownDocument input tree
  where
    input = hashes level <> header_text <> "\n\n1) " <> item_1 <> "\n2) " <> item_2 <> "\n3) " <> item_3
    tree =
      Doc
        [ Heading (H {level, text = [Text header_text]}) mempty,
          orderedList [item item_1, item item_2, item item_3]
        ]

simple_nested_ordered_list :: AlphaText -> AlphaText -> Property
simple_nested_ordered_list (AlphaText item_1) (AlphaText item_2) =
  monadicIO $ shouldParseTo markdownDocument input tree
  where
    input = "1) " <> item_1 <> "\n    1) " <> item_2
    tree =
      Doc
        [ orderedList
            [ LI {content = [Transparent [Text item_1], orderedList [item item_2]]}
            ]
        ]

-- - a
--      - a
-- - b
nested_unordered_list :: AlphaText -> AlphaText -> AlphaText -> Property
nested_unordered_list (AlphaText item_1) (AlphaText item_2) (AlphaText item_3) =
  monadicIO $ shouldParseTo markdownDocument input tree
  where
    input = "- " <> item_1 <> "\n    - " <> item_2 <> "\n- " <> item_3
    tree =
      Doc
        [ unorderedList
            [ LI {content = [Transparent [Text item_1], unorderedList [item item_2]]},
              item item_3
            ]
        ]

greedy_plain_text :: AlphaNumText -> AlphaNumText -> AlphaNumText -> Property
greedy_plain_text (AlphaNumText pretext) (AlphaNumText shown) (AlphaNumText url) =
  monadicIO $ shouldParseTo markdownDocument input tree
  where
    input = T.concat [pretext, "[", shown, "]", "(", url, ")"]
    tree =
      Doc
        [ Paragraph
            ( P
                [ Text pretext,
                  Link {linkText = [Text shown], url, title = Nothing, misc_attrs = mempty}
                ]
            )
            mempty
        ]

-- | Text written in a form the syntax says means that text has to come back
-- out as exactly that text, in one piece.
plain_text_is_literal :: MarkdownText -> Property
plain_text_is_literal (MarkdownText source) =
  monadicIO $ shouldParseTo markdownDocument source.rendered tree
  where
    tree = Doc [Paragraph (P [Text source.literal]) mempty]

-- | The generalisation of every test above it: a generated document, rendered
-- as markdown, has to parse back to the document it was generated from.
document_round_trip :: DocSpec -> Property
document_round_trip spec =
  counterexample (T.unpack source) $
    monadicIO $
      shouldParseTo markdownDocument source (expected markdownSyntax spec)
  where
    source = render markdownSyntax spec