628f01217e
The suite is now one tasty binary over shared modules, so the Djot
tests can sit next to the Markdown ones without another copy of the
harness:
tests/Main.hs the TestTree
tests/Test/Harness.hs running a parser inside a property
tests/Test/Gen.hs generators, shrinkers, escaping
tests/Test/Gen/Document.hs whole document generation
tests/Markdown/Parse.hs the Markdown properties
Generated values moved from `pick` to `Arbitrary` instances on
newtypes. `pick` embeds its value with `forAll (return a)` and cannot
shrink; going through Arbitrary gets shrinking back at the cost of
hand written shrinkers, which have to preserve the invariants their
generator established.
IR now derives Eq, and the properties assert against a complete
expected tree rather than pattern matching. The old patterns bound
fresh names that shadowed the generated ones, so they only ever
checked the shape of the tree and never its content.
Test.Gen.Document generates a description of a document which renders
to source and derives its own expected tree, so the two stay in step
while shrinking. Rendering goes through a Syntax record so Djot can
reuse the spec and the expectations. Escaping is a generator level
concern: an Escaper says which characters are special and how (or
whether) they can be written literally.
Two properties fail, both on parser bugs rather than test bugs:
code_block fencedCodeBlock inverts its language test, so a
fence naming a language reports Nothing. Djot.hs
gets this right at src/Djot.hs:354.
document_round_trip a nested list with more than one item makes the
whole list fail to parse and fall back to a
paragraph. In listBlock's child parser the second
alternative has no `try`, so it fails having
consumed the first item's indentation. The
existing nesting tests only ever used one nested
item.
Co-Authored-By: Claude Opus 5 <noreply@anthropic.com>
93 lines
3.1 KiB
Haskell
93 lines
3.1 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,
|
|
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
|