0f356e4d5e
Expectations come from the djot syntax reference and IR.hs rather than from what the parser currently produces, so a failure is evidence of a bug instead of a record of one. 55 properties: 32 inline (emphasis, verbatim, math, raw, links, images, references, autolinks, spans, attributes, footnotes, symbols, escapes, smart punctuation) and 23 block (headings, quotes, breaks, code fences, divs, raw blocks, every ordered marker style and delimiter, tight vs loose items, nesting, task lists, definition lists, tables, definitions, block attributes, round trip). Two rules are deliberately unasserted and noted in the module header: headings of seven or more hashes, and the general verbatim space stripping rule, of which only the unambiguous backtick case is tested. Three deviations the suite found, fixed in Djot.hs: - an unclosed verbatim span failed the construct back into plain text. The reference says it "extends to the end of the text"; manyTill cannot say that on its own, it needs the eof alternative. - a task list checkbox was recognised without the space the reference requires after it, so "1. [x](5)" ate a link and turned it into a checked item containing a list starting at 5. - checkboxes were recognised on ordered items, but the reference gives them to bullet items only. Test.Gen.Document is now shared by both suites. Syntax grew quoteContent and listTypeFor for the two places markdown and djot disagree about the resulting IR, and two djot facts became generator invariants rather than assertions: adjacent markup sharing a delimiter is ambiguous, so runs separate it, and a blank line between two lists makes one loose list rather than two blocks, so documents never place lists back to back. The test suite is no longer markdown only, so it is just "tests" now. Co-Authored-By: Claude Opus 5 <noreply@anthropic.com>
98 lines
3.2 KiB
Haskell
98 lines
3.2 KiB
Haskell
{-# LANGUAGE OverloadedStrings #-}
|
|
|
|
-- | Running a document parser inside a property and turning the result into a
|
|
-- QuickCheck verdict. Everything here is parser agnostic so the Djot suite can
|
|
-- share it with the Markdown one.
|
|
module Test.Harness
|
|
( DocumentParser,
|
|
markdownDocument,
|
|
djotDocument,
|
|
shouldParseTo,
|
|
shouldParse,
|
|
succeed,
|
|
failWith,
|
|
)
|
|
where
|
|
|
|
import Control.Exception (evaluate)
|
|
import Data.Functor.Identity (Identity)
|
|
import Data.Text (Text)
|
|
import Data.Void (Void)
|
|
import qualified Djot
|
|
import IR (Document)
|
|
import qualified Markdown
|
|
import System.Timeout (timeout)
|
|
import Test.QuickCheck (counterexample)
|
|
import Test.QuickCheck.Monadic (PropertyM, run, stop)
|
|
import Text.Megaparsec (ParsecT, errorBundlePretty, parse)
|
|
|
|
-- | A document parser pinned to the concrete stream and monad the tests use.
|
|
type DocumentParser = ParsecT Void Text Identity Document
|
|
|
|
markdownDocument :: DocumentParser
|
|
markdownDocument = Markdown.document
|
|
|
|
djotDocument :: DocumentParser
|
|
djotDocument = Djot.document
|
|
|
|
-- | What running a parser over an input told us. Timeouts are a failure mode in
|
|
-- their own right because a parser bug is much more likely to loop than to
|
|
-- throw.
|
|
data Outcome
|
|
= TimedOut
|
|
| Failed String
|
|
| Passed
|
|
|
|
-- | 1 second, every test here should finish orders of magnitude below that
|
|
parseTimeout :: Int
|
|
parseTimeout = 1000000
|
|
|
|
-- | Both the parse and the check on its result happen inside the timeout, a
|
|
-- comparison against a lazily built infinite tree would otherwise hang outside
|
|
-- of it.
|
|
attempt :: DocumentParser -> Text -> (Document -> Maybe String) -> PropertyM IO Outcome
|
|
attempt parser input check = do
|
|
result <- run $
|
|
timeout parseTimeout $ do
|
|
parsed <- evaluate $ parse parser "test_input" input
|
|
case parsed of
|
|
Left e -> pure . Failed $ errorBundlePretty e
|
|
Right actual -> case check actual of
|
|
Nothing -> pure Passed
|
|
Just message -> do
|
|
-- force the message, building it is what forces the tree
|
|
_ <- evaluate $ length message
|
|
pure $ Failed message
|
|
pure $ maybe TimedOut id result
|
|
|
|
verdict :: Outcome -> PropertyM IO ()
|
|
verdict TimedOut = failWith "Hit Timeout"
|
|
verdict (Failed message) = failWith message
|
|
verdict Passed = succeed
|
|
|
|
-- | The input must parse to exactly this tree.
|
|
shouldParseTo :: DocumentParser -> Text -> Document -> PropertyM IO ()
|
|
shouldParseTo parser input expected = verdict =<< attempt parser input check
|
|
where
|
|
check actual
|
|
| actual == expected = Nothing
|
|
| otherwise =
|
|
Just $
|
|
unlines
|
|
[ "input: " <> show input,
|
|
"expected: " <> show expected,
|
|
"actual: " <> show actual
|
|
]
|
|
|
|
-- | The input must parse, with no claim about what it parses to. For the cases
|
|
-- where the parser only has to not fall over.
|
|
shouldParse :: DocumentParser -> Text -> PropertyM IO ()
|
|
shouldParse parser input = verdict =<< attempt parser input (const Nothing)
|
|
|
|
-- | the equivalent of Hedgehog's `success`
|
|
succeed :: PropertyM IO ()
|
|
succeed = pure ()
|
|
|
|
-- | the equivalent of Hedgehog's `fail`
|
|
failWith :: String -> PropertyM IO a
|
|
failWith message = stop $ counterexample message False
|