diff --git a/psb.cabal b/psb.cabal index bddd0f2..a7506f9 100644 --- a/psb.cabal +++ b/psb.cabal @@ -35,9 +35,10 @@ library test-suite test-markdown-parse hs-source-dirs: tests type: exitcode-stdio-1.0 - main-is: Markdown/Parse.hs + main-is: Main.hs + other-modules: Test.Gen, Test.Gen.Document, Test.Harness, Markdown.Parse build-depends: base, text, megaparsec, transformers, QuickCheck, tasty, tasty-quickcheck, time, psb - + default-extensions: ApplicativeDo DataKinds NamedFieldPuns DerivingVia LambdaCase TypeApplications DeriveGeneric OverloadedRecordDot NamedFieldPuns DuplicateRecordFields DisambiguateRecordFields FlexibleInstances default-language: Haskell2010 diff --git a/src/IR.hs b/src/IR.hs index b85b19b..ae181ad 100644 --- a/src/IR.hs +++ b/src/IR.hs @@ -4,7 +4,7 @@ import Control.Applicative ((<|>)) import Data.Text newtype Document = Doc [Element] - deriving (Show) + deriving (Show, Eq) data Element = Heading Heading Attrs @@ -25,7 +25,7 @@ data Element | RawBlock RawBlock Attrs | TaskList TaskList Attrs | ReferenceDefinition RefDef - deriving (Show) + deriving (Show, Eq) -- Removed: BlankLine @@ -33,37 +33,37 @@ data Heading = H { level :: Int, text :: [InlineText] } - deriving (Show) + deriving (Show, Eq) data Code = C { language :: Maybe Text, code :: Text } - deriving (Show) + deriving (Show, Eq) -newtype BlockQuote = Q [Element] deriving (Show) +newtype BlockQuote = Q [Element] deriving (Show, Eq) newtype ListItem = LI -- children are just more elements { content :: [Element] -- Flatten continuations into here } - deriving (Show) + deriving (Show, Eq) -data ListType = Ordered {start_number :: Maybe Int, style :: Maybe Text} | Unordered {style :: Maybe Text} deriving (Show) +data ListType = Ordered {start_number :: Maybe Int, style :: Maybe Text} | Unordered {style :: Maybe Text} deriving (Show, Eq) data List = L { list_type :: ListType, items :: [ListItem] } - deriving (Show) + deriving (Show, Eq) newtype HTML = HTMLTag { html_content :: Text } - deriving (Show) + deriving (Show, Eq) -newtype Paragraph = P [InlineText] deriving (Show) +newtype Paragraph = P [InlineText] deriving (Show, Eq) data InlineText = Text Text -- Combined Normal and Escaped @@ -110,14 +110,14 @@ data InlineText | RawInline RawInline Attrs | Span [InlineText] Attrs | LineBreak - deriving (Show) + deriving (Show, Eq) data Attrs = Attrs { attrId :: Maybe Text, attrClasses :: [Text], attrKV :: [(Text, Text)] } - deriving (Show) + deriving (Show, Eq) instance Semigroup Attrs where a <> b = @@ -133,17 +133,17 @@ instance Monoid Attrs where data Math = InlineLaTeX Text | BlockLaTeX Text - deriving (Show) + deriving (Show, Eq) data Alignment = AlignLeft | AlignRight | AlignCenter | AlignDefault - deriving (Show) + deriving (Show, Eq) newtype TableCell = TC { cellContent :: [InlineText] } - deriving (Show) + deriving (Show, Eq) -newtype TableRow = TR [TableCell] deriving (Show) +newtype TableRow = TR [TableCell] deriving (Show, Eq) data Table = T { tableCaption :: Maybe [InlineText], @@ -151,43 +151,43 @@ data Table = T tableBody :: [TableRow], columnAlignments :: Maybe [Alignment] } - deriving (Show) + deriving (Show, Eq) -newtype DescriptionList = DL {items :: [DefinitionItem]} deriving (Show) +newtype DescriptionList = DL {items :: [DefinitionItem]} deriving (Show, Eq) data DefinitionItem = Def { defTitle :: [InlineText], defContent :: [Element] } - deriving (Show) + deriving (Show, Eq) -data Footnote = F {label :: Text, content :: [Element]} deriving (Show) +data Footnote = F {label :: Text, content :: [Element]} deriving (Show, Eq) -newtype TaskList = TL {items :: [Task]} deriving (Show) +newtype TaskList = TL {items :: [Task]} deriving (Show, Eq) data Task = Ta { checked :: Bool, content :: [Element] } - deriving (Show) + deriving (Show, Eq) data RawInline = RI { format :: Text, content :: Text } - deriving (Show) + deriving (Show, Eq) data RawBlock = RB { format :: Text, content :: Text } - deriving (Show) + deriving (Show, Eq) data RefDef = RD { label :: Text, link :: Text } - deriving (Show) + deriving (Show, Eq) -- for processing math -- https://hackage.haskell.org/package/typst-0.6.1/docs/Typst-Parse.html#v:parseTypst diff --git a/tests/Main.hs b/tests/Main.hs new file mode 100644 index 0000000..2bcb050 --- /dev/null +++ b/tests/Main.hs @@ -0,0 +1,12 @@ +module Main (main) where + +import qualified Markdown.Parse +import Test.Tasty (defaultMain, testGroup) + +main :: IO () +main = + defaultMain $ + testGroup + "Parse Tests" + [ Markdown.Parse.tests + ] diff --git a/tests/Markdown/Parse.hs b/tests/Markdown/Parse.hs index a600000..78baa32 100644 --- a/tests/Markdown/Parse.hs +++ b/tests/Markdown/Parse.hs @@ -1,28 +1,21 @@ {-# LANGUAGE OverloadedStrings #-} -module Main where +module Markdown.Parse (tests) 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.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) -import Text.Megaparsec (ParseErrorBundle, ParsecT, errorBundlePretty, parse) - -main :: IO () -main = defaultMain tests tests :: TestTree tests = testGroup - "Parse Tests" + "Markdown" [ testProperty "all_compile" all_compiles, testProperty "block_html_compile_edgecase" block_html_compile_edgecase, testProperty "header_and_paragraph" header_and_paragraph, @@ -38,324 +31,199 @@ tests = 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 "" , + testProperty "greedy_plain_text" greedy_plain_text, + testProperty "plain_text_is_literal" plain_text_is_literal, + testProperty "document_round_trip" document_round_trip ] --- 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) +hashes :: Int -> T.Text +hashes level = T.replicate level "#" -textOf :: Gen Char -> Int -> Int -> Gen Text -textOf char_gen lo hi = do - len <- linear lo hi - T.pack <$> vectorOf len char_gen +all_compiles :: AsciiText -> Property +all_compiles (AsciiText input) = monadicIO $ shouldParse markdownDocument input -ascii :: Gen Char -ascii = elements ['\0' .. '\127'] +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, " ", misc2] -alpha :: Gen Char -alpha = elements (['a' .. 'z'] <> ['A' .. 'Z']) +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 + ] -alphaNum :: Gen Char -alphaNum = elements (['a' .. 'z'] <> ['A' .. 'Z'] <> ['0' .. '9']) +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 + ] --- 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 +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 + ] --- the equivalent of Hedgehog's `success` -succeed :: PropertyM IO () -succeed = pure () +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] --- the equivalent of Hedgehog's `fail` -failWith :: String -> PropertyM IO a -failWith message = stop $ counterexample message False +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 <> "```") -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 +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 + ] -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, " ", misc2]) - case parsed of - Nothing -> failWith "Hit Timeout" - (Just (Right _)) -> succeed - (Just (Left e)) -> failWith $ errorBundlePretty e +item :: T.Text -> ListItem +item content = LI {content = [Transparent [Text content]]} -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 +unorderedList :: [ListItem] -> Element +unorderedList items = List (L {list_type = Unordered {style = Nothing}, items}) mempty - let input = (T.pack $ take header_level $ repeat '#') <> header_text <> "\n\n" <> paragraph_text +orderedList :: [ListItem] -> Element +orderedList items = List (L {list_type = Ordered {start_number = Nothing, style = Nothing}, items}) mempty - parsed <- generic_parse input +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]] - 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 +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 + ] -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 +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]] - let input = paragraph1_text <> "\n\n" <> (T.pack $ take header_level $ repeat '#') <> header_text <> "\n\n" <> paragraph2_text +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] + ] - parsed <- generic_parse input +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] + ] - 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 +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 :: 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 +nested_unordered_list :: AlphaText -> AlphaText -> AlphaText -> Property +nested_unordered_list (AlphaText item_1) (AlphaText item_2) (AlphaText item_3) = + monadicIO $ shouldParseTo markdownDocument input tree + where + input = "- " <> item_1 <> "\n - " <> item_2 <> "\n- " <> item_3 + tree = + Doc + [ unorderedList + [ LI {content = [Transparent [Text item_1], unorderedList [item item_2]]}, + item item_3 + ] + ] - parsed <- generic_parse input - case parsed of - Nothing -> 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 +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 + ] --- ## --- 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 +-- | Text written in a form the syntax says means that text has to come back +-- out as exactly that text, in one piece. +plain_text_is_literal :: MarkdownText -> Property +plain_text_is_literal (MarkdownText source) = + monadicIO $ shouldParseTo markdownDocument source.rendered tree + where + tree = Doc [Paragraph (P [Text source.literal]) mempty] - parsed <- generic_parse 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 +-- | 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 spec) + where + source = render markdownSyntax spec diff --git a/tests/Test/Gen.hs b/tests/Test/Gen.hs new file mode 100644 index 0000000..d170b04 --- /dev/null +++ b/tests/Test/Gen.hs @@ -0,0 +1,179 @@ +{-# 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 (..), + HeaderLevel (..), + + -- * escaping + Escaper (..), + backslashEscaper, + unescapable, + markdownEscaper, + escapeWith, + EscapedText (..), + escapedText, + MarkdownText (..), + ) +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 + +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 "`*[~_!<" + +-- | 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 diff --git a/tests/Test/Gen/Document.hs b/tests/Test/Gen/Document.hs new file mode 100644 index 0000000..6dc306a --- /dev/null +++ b/tests/Test/Gen/Document.hs @@ -0,0 +1,289 @@ +{-# 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, + 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 (PlainS a : PlainS b : rest) = mkRun (PlainS (a <> b) : rest) +mkRun (x : rest) = x : mkRun rest +mkRun [] = [] + +-- * generation + +instance Arbitrary DocSpec where + arbitrary = sized $ \size -> do + count <- chooseInt (1, 1 + min 3 (size `div` 8)) + DocSpec <$> vectorOf count blockSpec + + -- an empty document is legitimate, `document` is a `many` + shrink (DocSpec blocks) = DocSpec <$> shrinkList shrinkBlock blocks + +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. The expectations are shared, +-- only this differs between Markdown and Djot. +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 + } + +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" + } + where + 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 :: DocSpec -> Document +expected (DocSpec blocks) = Doc $ map expectedBlock blocks + +expectedBlock :: BlockSpec -> Element +expectedBlock = \case + ParagraphS run -> Paragraph (P (expectedRun run)) mempty + HeadingS level run -> Heading (H {level, text = expectedRun run}) mempty + QuoteS run -> BlockQuote (Q [Transparent (expectedRun run)]) mempty + ListS marker items -> List (expectedList marker items) mempty + +expectedList :: Marker -> [ItemSpec] -> List +expectedList marker items = L {list_type = expectedType marker, items = map expectedItem items} + +expectedType :: Marker -> ListType +expectedType (Bullet _) = Unordered {style = Nothing} +expectedType (Numbered _) = Ordered {start_number = Nothing, style = Nothing} + +expectedItem :: ItemSpec -> ListItem +expectedItem (ItemS run nested) = LI {content = Transparent (expectedRun run) : child} + where + child = case nested of + Nothing -> [] + Just (marker, runs) -> [List (expectedList 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} diff --git a/tests/Test/Harness.hs b/tests/Test/Harness.hs new file mode 100644 index 0000000..417fbbc --- /dev/null +++ b/tests/Test/Harness.hs @@ -0,0 +1,93 @@ +{-# 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, + shouldParseTo, + shouldParse, + succeed, + failWith, + ) +where + +import Control.Exception (evaluate) +import Data.Functor.Identity (Identity) +import Data.Text (Text) +import Data.Void (Void) +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 + +-- | 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