module Test.Cleveland.Internal.Exceptions
( WithCallStack(..)
, addCallStack
, throwWithCallStack
, tryWithCallStack
, catchWithCallStack
) where
import Data.Typeable (cast)
import Fmt (Buildable(..), pretty, unlinesF)
data WithCallStack where
WithCallStack :: CallStack -> SomeException -> WithCallStack
deriving stock instance Show WithCallStack
instance Buildable WithCallStack where
build :: WithCallStack -> Builder
build (WithCallStack CallStack
cstack SomeException
e) = [String] -> Builder
forall (f :: * -> *) a. (Foldable f, Buildable a) => f a -> Builder
unlinesF
[ CallStack -> String
prettyCallStack CallStack
cstack
, SomeException -> String
forall e. Exception e => e -> String
displayException SomeException
e
]
instance Exception WithCallStack where
displayException :: WithCallStack -> String
displayException = WithCallStack -> String
forall a b. (Buildable a, FromBuilder b) => a -> b
pretty
addCallStack :: forall m a. (HasCallStack, MonadCatch m) => m a -> m a
addCallStack :: forall (m :: * -> *) a. (HasCallStack, MonadCatch m) => m a -> m a
addCallStack m a
ma =
m a
ma m a -> (SomeException -> m a) -> m a
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` \se :: SomeException
se@(SomeException e
ex) ->
case forall e. Exception e => SomeException -> Maybe e
fromException @WithCallStack SomeException
se of
Just (WithCallStack CallStack
_ SomeException
innerEx) -> CallStack -> SomeException -> m a
forall e a (m :: * -> *).
(MonadThrow m, Exception e) =>
CallStack -> e -> m a
throwWithCallStack CallStack
HasCallStack => CallStack
callStack SomeException
innerEx
Maybe WithCallStack
Nothing -> CallStack -> e -> m a
forall e a (m :: * -> *).
(MonadThrow m, Exception e) =>
CallStack -> e -> m a
throwWithCallStack CallStack
HasCallStack => CallStack
callStack e
ex
throwWithCallStack :: forall e a m. (MonadThrow m, Exception e) => CallStack -> e -> m a
throwWithCallStack :: forall e a (m :: * -> *).
(MonadThrow m, Exception e) =>
CallStack -> e -> m a
throwWithCallStack CallStack
cstack e
ex = WithCallStack -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (CallStack -> SomeException -> WithCallStack
WithCallStack CallStack
cstack (e -> SomeException
forall e. Exception e => e -> SomeException
toException e
ex))
catchWithCallStack
:: forall e a m. (Exception e, MonadCatch m)
=> m a -> (Maybe CallStack -> e -> m a) -> m a
catchWithCallStack :: forall e a (m :: * -> *).
(Exception e, MonadCatch m) =>
m a -> (Maybe CallStack -> e -> m a) -> m a
catchWithCallStack m a
ma Maybe CallStack -> e -> m a
f =
m a
ma m a -> (SomeException -> m a) -> m a
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` \(SomeException
se :: SomeException) ->
case forall e.
Exception e =>
SomeException -> Maybe (Maybe CallStack, e)
fromExceptionWithCallStack @e SomeException
se of
Just (Maybe CallStack
cstackMb, e
e) -> Maybe CallStack -> e -> m a
f Maybe CallStack
cstackMb e
e
Maybe (Maybe CallStack, e)
Nothing -> SomeException -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM SomeException
se
tryWithCallStack :: forall e a m. (MonadCatch m, Exception e) => m a -> m (Either (Maybe CallStack, e) a)
tryWithCallStack :: forall e a (m :: * -> *).
(MonadCatch m, Exception e) =>
m a -> m (Either (Maybe CallStack, e) a)
tryWithCallStack m a
ma =
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
try @_ @SomeException m a
ma m (Either SomeException a)
-> (Either SomeException a -> m (Either (Maybe CallStack, e) a))
-> m (Either (Maybe CallStack, e) a)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Right a
a -> Either (Maybe CallStack, e) a -> m (Either (Maybe CallStack, e) a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> Either (Maybe CallStack, e) a
forall a b. b -> Either a b
Right a
a)
Left SomeException
se ->
case forall e.
Exception e =>
SomeException -> Maybe (Maybe CallStack, e)
fromExceptionWithCallStack @e SomeException
se of
Just (Maybe CallStack, e)
e -> Either (Maybe CallStack, e) a -> m (Either (Maybe CallStack, e) a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Maybe CallStack, e) -> Either (Maybe CallStack, e) a
forall a b. a -> Either a b
Left (Maybe CallStack, e)
e)
Maybe (Maybe CallStack, e)
Nothing -> SomeException -> m (Either (Maybe CallStack, e) a)
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM SomeException
se
fromExceptionWithCallStack :: forall e. Exception e => SomeException -> Maybe (Maybe CallStack, e)
fromExceptionWithCallStack :: forall e.
Exception e =>
SomeException -> Maybe (Maybe CallStack, e)
fromExceptionWithCallStack SomeException
se =
(do
WithCallStack CallStack
cstack SomeException
e <- forall e. Exception e => SomeException -> Maybe e
fromException @WithCallStack SomeException
se
e
e' <- forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast @_ @e SomeException
e
(Maybe CallStack, e) -> Maybe (Maybe CallStack, e)
forall a. a -> Maybe a
Just (CallStack -> Maybe CallStack
forall a. a -> Maybe a
Just CallStack
cstack, e
e')
)
Maybe (Maybe CallStack, e)
-> Maybe (Maybe CallStack, e) -> Maybe (Maybe CallStack, e)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
(forall e. Exception e => SomeException -> Maybe e
fromException @e SomeException
se Maybe e
-> (e -> (Maybe CallStack, e)) -> Maybe (Maybe CallStack, e)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (Maybe CallStack
forall a. Maybe a
Nothing,))