-- 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 :: forall (m :: * -> *).
(HasCallStack, MonadIO m, MonadTest m) =>
Scenario PureM -> m ()
testScenarioProps (ScenarioEmulated EmulatedT PureM ()
s) = IO () -> m ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, MonadTest m) =>
IO a -> m a
evalIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ ImplicitAlias -> EmulatedT PureM () -> IO ()
forall a. ImplicitAlias -> EmulatedT PureM a -> IO a
runEmulatedT ImplicitAlias
moneybagAlias EmulatedT PureM ()
s

evalIO :: (HasCallStack, MonadIO m, MonadTest m) => IO a -> m a
evalIO :: forall (m :: * -> *) a.
(HasCallStack, MonadIO m, MonadTest m) =>
IO a -> m a
evalIO IO a
m = (SomeException -> m a)
-> (a -> m a) -> Either SomeException a -> m a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ((HasCallStack => SomeException -> m a) -> SomeException -> m a
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack HasCallStack => SomeException -> m a
forall (m :: * -> *) a.
(HasCallStack, MonadTest m) =>
SomeException -> m a
failWithException) a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either SomeException a -> m a)
-> m (Either SomeException a) -> m a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO (Either SomeException a) -> m (Either SomeException a)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> IO (Either SomeException a)
forall (m :: * -> *) a.
MonadCatch m =>
m a -> m (Either SomeException a)
tryAll IO a
m)

failWithException :: (HasCallStack, MonadTest m) => SomeException -> m a
failWithException :: forall (m :: * -> *) a.
(HasCallStack, MonadTest m) =>
SomeException -> m a
failWithException SomeException
e =
  CallStack -> String -> m a
forall (m :: * -> *) a. MonadTest m => CallStack -> String -> m a
failWithCallStack (CallStack -> Maybe CallStack -> CallStack
forall a. a -> Maybe a -> a
fromMaybe CallStack
HasCallStack => CallStack
callStack (Maybe CallStack -> CallStack) -> Maybe CallStack -> CallStack
forall a b. (a -> b) -> a -> b
$ CallStackAnnotation -> CallStack
unCallStackAnnotation (CallStackAnnotation -> CallStack)
-> Maybe CallStackAnnotation -> Maybe CallStack
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SomeException -> Maybe CallStackAnnotation
forall ann. ExceptionAnnotation ann => SomeException -> Maybe ann
lookupAnnEx SomeException
e) (String -> m a) -> String -> m a
forall a b. (a -> b) -> a -> b
$
    SomeException -> String
formatException SomeException
e

failWithCallStack :: (MonadTest m) => CallStack -> String -> m a
failWithCallStack :: forall (m :: * -> *) a. MonadTest m => CallStack -> String -> m a
failWithCallStack CallStack
cs String
message = Test a -> m a
forall (m :: * -> *) a. MonadTest m => Test a -> m a
liftTest (Test a -> m a) -> Test a -> m a
forall a b. (a -> b) -> a -> b
$ (Either Failure a, Journal) -> Test a
forall a. (Either Failure a, Journal) -> Test a
mkTest
  (Failure -> Either Failure a
forall a b. a -> Either a b
Left (Failure -> Either Failure a) -> Failure -> Either Failure a
forall a b. (a -> b) -> a -> b
$ Maybe Span -> String -> Maybe Diff -> Failure
Failure (CallStack -> Maybe Span
extractSpan CallStack
cs) String
message Maybe Diff
forall a. Maybe a
Nothing, Journal
forall a. Monoid a => a
mempty)

formatException :: SomeException -> String
formatException :: SomeException -> String
formatException (SomeException e
e) =
  [String] -> String
String.unlines [
    String
"━━━ Exception (" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> TypeRep -> String
forall b a. (PrettyShow a, Show a, IsString b) => a -> b
show (e -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf e
e) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
") ━━━"
    , (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhileEnd Char -> Bool
isSpace (e -> String
forall e. Exception e => e -> String
displayException e
e)
  ]

extractSpan :: CallStack -> Maybe Span
extractSpan :: CallStack -> Maybe Span
extractSpan CallStack
cs =
  [(String, SrcLoc)] -> Maybe (NonEmpty (String, SrcLoc))
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty (CallStack -> [(String, SrcLoc)]
getCallStack CallStack
cs)
    Maybe (NonEmpty (String, SrcLoc))
-> (NonEmpty (String, SrcLoc) -> (String, SrcLoc))
-> Maybe (String, SrcLoc)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> NonEmpty (String, SrcLoc) -> (String, SrcLoc)
forall a. NonEmpty a -> a
last
    Maybe (String, SrcLoc) -> ((String, SrcLoc) -> Span) -> Maybe Span
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \(String
_, SrcLoc{Int
String
srcLocEndCol :: Int
srcLocEndLine :: Int
srcLocStartCol :: Int
srcLocStartLine :: Int
srcLocFile :: String
srcLocStartLine :: SrcLoc -> Int
srcLocStartCol :: SrcLoc -> Int
srcLocFile :: SrcLoc -> String
srcLocEndLine :: SrcLoc -> Int
srcLocEndCol :: SrcLoc -> Int
..}) ->
      String -> LineNo -> ColumnNo -> LineNo -> ColumnNo -> Span
Span
        String
srcLocFile
        (Int -> LineNo
coerce Int
srcLocStartLine)
        (Int -> ColumnNo
coerce Int
srcLocStartCol)
        (Int -> LineNo
coerce Int
srcLocEndLine)
        (Int -> ColumnNo
coerce Int
srcLocEndCol)