Hedgehog.hs

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

{-# OPTIONS_HADDOCK not-home #-}

-- | Hedgehog-related helpers
module Test.Cleveland.Internal.Hedgehog
  ( module Test.Cleveland.Internal.Hedgehog
  ) 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
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 =
  failWithCallStack (fromMaybe callStack $ unCallStackAnnotation <$> lookupAnnEx e) $
    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)