psb/tests/Markdown/Parse.hs

{-# LANGUAGE OverloadedStrings #-}

module Main where

import Control.Exception (evaluate)
import Data.Functor.Identity (Identity)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Void (Void)
import IR
import qualified Markdown
import System.Timeout (timeout)
import Test.QuickCheck (Gen, Property, chooseInt, counterexample, elements, sized, vectorOf)
import Test.QuickCheck.Monadic (PropertyM, monadicIO, pick, run, stop)
import Test.Tasty (TestTree, defaultMain, testGroup)
import Test.Tasty.QuickCheck (testProperty)
import Text.Megaparsec (ParseErrorBundle, ParsecT, errorBundlePretty, parse)

main :: IO ()
main = defaultMain tests

tests :: TestTree
tests =
  testGroup
    "Parse Tests"
    [ 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 "" ,
    ]

-- Hedgehog's Range.linear grows the upper bound with the size of the test
-- case, this is the same thing in terms of QuickCheck's sizing
linear :: Int -> Int -> Gen Int
linear lo hi = sized $ \size ->
  let scaled = lo + ((hi - lo) * min size 99) `div` 99
   in chooseInt (lo, max lo scaled)

textOf :: Gen Char -> Int -> Int -> Gen Text
textOf char_gen lo hi = do
  len <- linear lo hi
  T.pack <$> vectorOf len char_gen

ascii :: Gen Char
ascii = elements ['\0' .. '\127']

alpha :: Gen Char
alpha = elements (['a' .. 'z'] <> ['A' .. 'Z'])

alphaNum :: Gen Char
alphaNum = elements (['a' .. 'z'] <> ['A' .. 'Z'] <> ['0' .. '9'])

-- timeout of 1 second, all of these tests should be completely clear of that, if they run longer they should fail
generic_parse :: Text -> PropertyM IO (Maybe (Either (ParseErrorBundle Text Void) Document))
generic_parse inp = run $ timeout 1000000 $ evaluate $ parse (Markdown.document :: ParsecT Void Text Identity IR.Document) "test_input" inp

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

all_compiles :: Property
all_compiles = monadicIO $ do
  xs <- pick $ textOf ascii 0 100
  parsed <- generic_parse xs
  case parsed of
    Nothing -> failWith "Hit Timeout"
    (Just (Right _)) -> succeed
    (Just (Left e)) -> failWith $ errorBundlePretty e

block_html_compile_edgecase :: Property
block_html_compile_edgecase = monadicIO $ do
  let gen = pick $ textOf alphaNum 0 10
  tagName <- gen
  misc1 <- gen
  misc2 <- gen
  parsed <- generic_parse $ (T.concat ["<", tagName, ">", misc1, "</", tagName, "> ", misc2])
  case parsed of
    Nothing -> failWith "Hit Timeout"
    (Just (Right _)) -> succeed
    (Just (Left e)) -> failWith $ errorBundlePretty e

header_and_paragraph :: Property
header_and_paragraph = monadicIO $ do
  header_text <- pick $ textOf alpha 1 10
  header_level <- pick $ linear 1 6
  paragraph_text <- pick $ textOf alpha 1 10

  let input = (T.pack $ take header_level $ repeat '#') <> header_text <> "\n\n" <> paragraph_text

  parsed <- generic_parse input

  case parsed of
    Nothing -> failWith "Hit Timeout"
    (Just (Right (Doc [Heading (H {level = header_level, text = [Text (header_text)]}) _, Paragraph (P ([Text paragraph_text])) _]))) -> succeed
    (Just (Right tree)) -> failWith $ "Incorrect syntax tree: " <> show tree
    (Just (Left e)) -> failWith $ errorBundlePretty e

paragraph_and_header_and_paragraph :: Property
paragraph_and_header_and_paragraph = monadicIO $ do
  paragraph1_text <- pick $ textOf alpha 1 10
  header_text <- pick $ textOf alpha 1 10
  header_level <- pick $ linear 1 6
  paragraph2_text <- pick $ textOf alpha 1 10

  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 -> failWith "Hit Timeout"
    (Just (Right (Doc [Paragraph (P ([Text paragarph1_text])) _, Heading (H {level = header_level, text = [Text (header_text)]}) _, Paragraph (P ([Text paragraph2_text])) _]))) -> succeed
    (Just (Right tree)) -> failWith $ "Incorrect syntax tree: " <> show tree
    (Just (Left e)) -> failWith $ errorBundlePretty e

bold_and_header_and_paragraph :: Property
bold_and_header_and_paragraph = monadicIO $ do
  bold_text <- pick $ textOf alpha 1 10
  header_text <- pick $ textOf alpha 1 10
  header_level <- pick $ linear 1 6
  paragraph_text <- pick $ textOf alpha 1 10

  let input = "**" <> bold_text <> "**\n\n" <> (T.pack $ take header_level $ repeat '#') <> header_text <> "\n\n" <> paragraph_text

  parsed <- generic_parse input

  case parsed of
    Nothing -> failWith "Hit Timeout"
    (Just (Right (Doc [Paragraph (P ([Bold [Text bold_text] _])) _, Heading (H {level = header_level, text = [Text (header_text)]}) _, Paragraph (P ([Text paragraph_text])) _]))) -> succeed
    (Just (Right tree)) -> failWith $ "Incorrect syntax tree: " <> show tree
    (Just (Left e)) -> failWith $ errorBundlePretty e

code_block :: Property
code_block = monadicIO $ do
  language <- pick $ textOf alpha 1 10
  code <- pick $ textOf alpha 1 10
  let input = "```" <> language <> "\n" <> code <> "\n```"
  parsed <- generic_parse input

  case parsed of
    Nothing -> failWith "Hit Timeout"
    (Just (Right (Doc [Code (C {language, code}) _]))) -> succeed
    (Just (Right tree)) -> failWith $ "Incorrect syntax tree: " <> show tree
    (Just (Left e)) -> failWith $ errorBundlePretty e

code_block_hanging :: Property
code_block_hanging = monadicIO $ do
  language <- pick $ textOf alpha 1 10
  code <- pick $ textOf alpha 1 10
  let input = "```" <> language <> "\n" <> code <> "```"
  parsed <- generic_parse input

  case parsed of
    Nothing -> failWith "Hit Timeout"
    -- we're just testing for hanging
    (Just (Right _)) -> succeed
    (Just (Left e)) -> failWith $ errorBundlePretty e

two_blockquotes :: Property
two_blockquotes = monadicIO $ do
  let text_gen = pick $ textOf alpha 1 10
  text_1 <- text_gen
  text_2 <- text_gen
  let input = "> " <> text_1 <> "\n\n> " <> text_2

  parsed <- generic_parse input

  case parsed of
    Nothing -> failWith "Hit Timeout"
    (Just (Right (Doc [BlockQuote (Q [Transparent [Text text_1]]) _, BlockQuote (Q [Transparent [Text text_2]]) _]))) -> succeed
    (Just (Right tree)) -> failWith $ "Incorrect syntax tree: " <> show tree
    (Just (Left e)) -> failWith $ errorBundlePretty e

unordered_list :: Property
unordered_list = monadicIO $ do
  let text_gen = pick $ textOf alpha 1 10
  text_1 <- text_gen
  text_2 <- text_gen
  let input = "- " <> text_1 <> "\n- " <> text_2

  parsed <- generic_parse input

  case parsed of
    Nothing -> failWith "Hit Timeout"
    (Just (Right (Doc [List (L {list_type = Unordered {}, items = [LI {content = [Transparent [Text text_1]]}, LI {content = [Transparent [Text text_2]]}]}) _]))) -> succeed
    (Just (Right tree)) -> failWith $ "Incorrect syntax tree: " <> show tree
    (Just (Left e)) -> failWith $ errorBundlePretty e

header_after_unordered_list :: Property
header_after_unordered_list = monadicIO $ do
  let text_gen = pick $ textOf alpha 1 10
  bullet_text <- text_gen
  header_text <- text_gen
  header_level <- pick $ linear 1 6

  let input = "- " <> bullet_text <> "\n\n" <> (T.pack $ take header_level $ repeat '#') <> header_text

  parsed <- generic_parse input

  case parsed of
    Nothing -> failWith "Hit Timeout"
    (Just (Right (Doc [List (L {list_type = Unordered {}, items = [LI {content = [Transparent [Text bullet_text]]}]}) _, Heading (H {level = header_level, text = [Text header_text]}) _]))) -> succeed
    (Just (Right tree)) -> failWith $ "Incorrect syntax tree: " <> show tree
    (Just (Left e)) -> failWith $ errorBundlePretty e

ordered_list :: Property
ordered_list = monadicIO $ do
  let text_gen = pick $ textOf alpha 1 10
  item_1 <- text_gen
  item_2 <- text_gen
  item_3 <- text_gen
  let input = "1. " <> item_1 <> "\n2. " <> item_2 <> "\n3. " <> item_3

  parsed <- generic_parse input

  case parsed of
    Nothing -> failWith "Hit Timeout"
    (Just (Right (Doc [List (L {list_type = Ordered {}, items = [LI {content = [Transparent [Text item_1]]}, LI {content = [Transparent [Text item_2]]}, LI {content = [Transparent [Text item_3]]}]}) _]))) -> succeed
    (Just (Right tree)) -> failWith $ "Incorrect syntax tree: " <> show tree
    (Just (Left e)) -> failWith $ errorBundlePretty e

multiple_ordered_lists :: Property
multiple_ordered_lists = monadicIO $ do
  let text_gen = pick $ textOf alpha 1 10
  item_1 <- text_gen
  item_2 <- text_gen
  item_3 <- text_gen
  let input = "1. " <> item_1 <> "\n\n2. " <> item_2 <> "\n\n3. " <> item_3

  parsed <- generic_parse input
  case parsed of
    Nothing -> failWith "Hit Timeout"
    ( Just
        ( Right
            ( Doc
                [ List (L {list_type = Ordered {}, items = [LI {content = [Transparent [Text item_1]]}]}) _,
                  List (L {list_type = Ordered {}, items = [LI {content = [Transparent [Text item_2]]}]}) _,
                  List (L {list_type = Ordered {}, items = [LI {content = [Transparent [Text item_3]]}]}) _
                  ]
              )
          )
      ) -> succeed
    (Just (Right tree)) -> failWith $ "Incorrect syntax tree: " <> show tree
    (Just (Left e)) -> failWith $ errorBundlePretty e

simple_nested_ordered_list :: Property
simple_nested_ordered_list = monadicIO $ do
  let text_gen = pick $ textOf alpha 1 10
  item_1 <- text_gen
  item_2 <- text_gen
  let input = "1) " <> item_1 <> "\n    1) " <> item_2

  parsed <- generic_parse input
  case parsed of
    Nothing -> failWith "Hit Timeout"
    ( Just
        ( Right
            ( Doc
                [ List (L {list_type = Ordered {}, items = [LI {content = [Transparent [Text item_1], List (L {list_type = Ordered {}, items = [LI {content = [Transparent [Text item_2]]}]}) _]}]}) _
                  ]
              )
          )
      ) -> succeed
    (Just (Right tree)) -> failWith $ "Incorrect syntax tree: " <> show tree
    (Just (Left e)) -> failWith $ errorBundlePretty e

-- - a
--      - a
-- - b
nested_unordered_list :: Property
nested_unordered_list = monadicIO $ do
  let text_gen = pick $ textOf alpha 1 10
  item_1 <- text_gen
  item_2 <- text_gen
  item_3 <- text_gen
  let input = "- " <> item_1 <> "\n    - " <> item_2 <> "\n- " <> item_3

  parsed <- generic_parse input
  case parsed of
    Nothing -> failWith "Hit Timeout"
    ( Just
        ( Right
            ( Doc
                [ List (L {list_type = Unordered {}, items = [LI {content = [Transparent [Text item_1], List (L {list_type = Unordered {}, items = [LI {content = [Transparent [Text item_2]]}]}) _]}, LI {content = [Transparent [Text item_3]]}]}) _
                  ]
              )
          )
      ) -> succeed
    (Just (Right tree)) -> failWith $ "Incorrect syntax tree: " <> show tree
    (Just (Left e)) -> failWith $ errorBundlePretty e

-- ##
-- 1)
-- 2)
-- 3)
header_then_ordered_list :: Property
header_then_ordered_list = monadicIO $ do
  let text_gen = pick $ textOf alpha 1 10
  header <- text_gen
  header_level <- pick $ linear 1 6
  item_1 <- text_gen
  item_2 <- text_gen
  item_3 <- text_gen
  let input = (T.pack $ take header_level $ repeat '#') <> header <> "\n\n1) " <> item_1 <> "\n2) " <> item_2 <> "\n3) " <> item_3

  parsed <- generic_parse input

  case parsed of
    Nothing -> failWith "Hit Timeout"
    ( Just
        ( Right
            ( Doc
                [ Heading (H {level = header_level, text = header}) _,
                  List
                    ( L
                        { list_type = Ordered {},
                          items =
                            [ LI {content = [Transparent [Text item_1]]},
                              LI {content = [Transparent [Text item_2]]},
                              LI {content = [Transparent [Text item_3]]}
                              ]
                        }
                      )
                    _
                  ]
              )
          )
      ) -> succeed
    (Just (Right tree)) -> failWith $ "Incorrect syntax tree: " <> show tree
    (Just (Left e)) -> failWith $ errorBundlePretty e

greedy_plain_text :: Property
greedy_plain_text = monadicIO $ do
  let text_gen = pick $ textOf alphaNum 1 10
  pretext <- text_gen
  shown <- text_gen
  link <- text_gen

  parsed <- generic_parse $ T.concat [pretext, "[", shown, "]", "(", link, ")"]

  case parsed of
    Nothing -> failWith "Hit Timeout"
    (Just (Right (Doc [Paragraph (P [Text (pretext), Link {linkText = [Text shown], url = link, title = Nothing}]) _]))) -> succeed
    (Just (Right tree)) -> failWith $ "Incorrect syntax tree: " <> show tree
    (Just (Left e)) -> failWith $ errorBundlePretty e