Hedgehog.hs

-- SPDX-FileCopyrightText: 2021 Oxhead Alpha
-- SPDX-License-Identifier: LicenseRef-MIT-OA

-- | Hedgehog-related helpers
module Test.Cleveland.Internal.Hedgehog
  ( MonadTest (..)
  , evalIO
  , testScenarioProps
  ) where

import Data.Char (isSpace)
import Data.Coerce (coerce)
import Data.List (dropWhileEnd)
import Data.String qualified as String
import Data.Typeable (typeOf)
import GHC.Stack
  (SrcLoc(SrcLoc), srcLocEndCol, srcLocEndLine, srcLocFile, srcLocStartCol, srcLocStartLine)
import Hedgehog.Internal.Exception (tryAll)
import Hedgehog.Internal.Property (Failure(..), MonadTest(..), mkTest)
import Hedgehog.Internal.Source (ColumnNo(..), LineNo(..), Span(..))

import Test.Cleveland.Internal.Exceptions (WithCallStack(..))
import Test.Cleveland.Internal.Pure
import Test.Cleveland.Internal.Scenario

-- | Run an 'Scenario' via the "Morley.Michelson.Runtime" emulator,
-- inside an @hedgehog@ property.
testScenarioProps :: (HasCallStack, MonadIO m, MonadTest m) => Scenario PureM -> m ()
testScenarioProps (ScenarioEmulated s) = evalIO $ runEmulatedT moneybagAlias s

evalIO :: (HasCallStack, MonadIO m, MonadTest m) => IO a -> m a
evalIO m = either (withFrozenCallStack failWithException) pure =<< liftIO (tryAll m)

failWithException :: (HasCallStack, MonadTest m) => SomeException -> m a
failWithException e =
  case fromException @WithCallStack e of
    Just (WithCallStack cs _) -> failWithCallStack cs message
    _                         -> failWithCallStack callStack message
  where
    message = formatException e

failWithCallStack :: (MonadTest m) => CallStack -> String -> m a
failWithCallStack cs message = liftTest $ mkTest
  (Left $ Failure (extractSpan cs) message Nothing, mempty)

formatException :: SomeException -> String
formatException (SomeException e) =
  String.unlines [
    "━━━ Exception (" <> show (typeOf e) <> ") ━━━"
    , dropWhileEnd isSpace (displayException e)
  ]

extractSpan :: CallStack -> Maybe Span
extractSpan cs =
  nonEmpty (getCallStack cs)
    <&> last
    <&> \(_, SrcLoc{..}) ->
      Span
        srcLocFile
        (coerce srcLocStartLine)
        (coerce srcLocStartCol)
        (coerce srcLocEndLine)
        (coerce srcLocEndCol)