{-# OPTIONS_HADDOCK not-home #-}
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
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
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)