-- 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 :: Scenario PureM -> m ()
testScenarioProps = IO () -> m ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, MonadTest m) =>
IO a -> m a
evalIO (IO () -> m ())
-> (Scenario PureM -> IO ()) -> Scenario PureM -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
  ScenarioCleveland ClevelandT PureM ()
s -> Alias -> ClevelandT PureM () -> IO ()
forall a. Alias -> ClevelandT PureM a -> IO a
runClevelandT Alias
moneybagAlias ClevelandT PureM ()
s
  ScenarioEmulated EmulatedT PureM ()
s -> Alias -> EmulatedT PureM () -> IO ()
forall a. Alias -> EmulatedT PureM a -> IO a
runEmulatedT Alias
moneybagAlias EmulatedT PureM ()
s

evalIO :: (HasCallStack, MonadIO m, MonadTest m) => IO a -> m a
evalIO :: 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 :: SomeException -> m a
failWithException SomeException
e =
  case SomeException -> Maybe WithCallStack
forall e. Exception e => SomeException -> Maybe e
fromException @WithCallStack SomeException
e of
    Just (WithCallStack CallStack
cs SomeException
_) -> CallStack -> String -> m a
forall (m :: * -> *) a. MonadTest m => CallStack -> String -> m a
failWithCallStack CallStack
cs String
message
    Maybe WithCallStack
_                         -> CallStack -> String -> m a
forall (m :: * -> *) a. MonadTest m => CallStack -> String -> m a
failWithCallStack CallStack
HasCallStack => CallStack
callStack String
message
  where
    message :: String
message = SomeException -> String
formatException SomeException
e

failWithCallStack :: (MonadTest m) => CallStack -> String -> m a
failWithCallStack :: 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)