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

-- | This module defines common exception types and exception-related functions
-- used throughout the "Test.Cleveland" modules.
module Test.Cleveland.Internal.Exceptions
  ( WithCallStack(..)
  , addCallStack
  , throwWithCallStack
  , tryWithCallStack
  , catchWithCallStack
  ) where

import Data.Typeable (cast)
import Fmt (Buildable(..), pretty, unlinesF)

----------------------------------------------------------------------------
-- WithCallStack
----------------------------------------------------------------------------

-- | Wraps an exception and adds some callstack information.
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

-- | Wrap any exceptions thrown by some monadic action with 'WithCallStack'.
--
-- If the action throws an exception already wrapped in 'WithCallStack',
-- that callstack will be overriden with the current one.
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))


-- | Similar to 'catch', but also catches exceptions of type @e@ wrapped in 'WithCallStack'.
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

-- | Attempts to run the given action.
--
-- If it:
--
-- * suceeds, the value will be returned in a 'Right'.
-- * throws an exception of the given type @e@ (or an exception of
--   type @e@ wrapped in 'WithCallStack'), it will be returned in a 'Left'.
-- * throws an exception of any other type, it'll be rethrown
--   (retaining the original callstack, if any).
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,))