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