{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE InstanceSigs #-}

module Cardano.Wasm.ExceptionHandling where

import Control.Exception (Exception, displayException)
import Control.Monad.Catch (MonadThrow (..))
import GHC.Exception (prettyCallStack)
import GHC.Stack (HasCallStack, callStack, withFrozenCallStack)

data ExpectedJustException = HasCallStack => ExpectedJustException String

instance Show ExpectedJustException where
  show :: ExpectedJustException -> String
  show :: ExpectedJustException -> String
show (ExpectedJustException String
msg) = String
"Expected Just, got Nothing: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
msg String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++ CallStack -> String
prettyCallStack CallStack
HasCallStack => CallStack
callStack

instance Exception ExpectedJustException

data ExpectedRightException = HasCallStack => ExpectedRightException String

instance Show ExpectedRightException where
  show :: ExpectedRightException -> String
  show :: ExpectedRightException -> String
show (ExpectedRightException String
msg) = String
"Expected Right, got Left: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
msg String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++ CallStack -> String
prettyCallStack CallStack
HasCallStack => CallStack
callStack

instance Exception ExpectedRightException

data CustomException = HasCallStack => CustomException String

instance Show CustomException where
  show :: CustomException -> String
  show :: CustomException -> String
show (CustomException String
msg) = String
"Custom exception: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
msg String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++ CallStack -> String
prettyCallStack CallStack
HasCallStack => CallStack
callStack

instance Exception CustomException

throwError :: (HasCallStack, MonadThrow m) => String -> m a
throwError :: forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
throwError String
e = (HasCallStack => m a) -> m a
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => m a) -> m a) -> (HasCallStack => m a) -> m a
forall a b. (a -> b) -> a -> b
$ CustomException -> m a
forall e a. (HasCallStack, Exception e) => e -> m a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM (CustomException -> m a) -> CustomException -> m a
forall a b. (a -> b) -> a -> b
$ HasCallStack => String -> CustomException
String -> CustomException
CustomException String
e

justOrError :: (HasCallStack, MonadThrow m) => String -> Maybe a -> m a
justOrError :: forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> Maybe a -> m a
justOrError String
e Maybe a
Nothing = (HasCallStack => m a) -> m a
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => m a) -> m a) -> (HasCallStack => m a) -> m a
forall a b. (a -> b) -> a -> b
$ ExpectedJustException -> m a
forall e a. (HasCallStack, Exception e) => e -> m a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM (ExpectedJustException -> m a) -> ExpectedJustException -> m a
forall a b. (a -> b) -> a -> b
$ HasCallStack => String -> ExpectedJustException
String -> ExpectedJustException
ExpectedJustException String
e
justOrError String
_ (Just a
a) = a -> m a
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a

rightOrError :: (HasCallStack, MonadThrow m, Show e) => Either e a -> m a
rightOrError :: forall (m :: * -> *) e a.
(HasCallStack, MonadThrow m, Show e) =>
Either e a -> m a
rightOrError (Left e
e) = (HasCallStack => m a) -> m a
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => m a) -> m a) -> (HasCallStack => m a) -> m a
forall a b. (a -> b) -> a -> b
$ ExpectedRightException -> m a
forall e a. (HasCallStack, Exception e) => e -> m a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM (ExpectedRightException -> m a) -> ExpectedRightException -> m a
forall a b. (a -> b) -> a -> b
$ HasCallStack => String -> ExpectedRightException
String -> ExpectedRightException
ExpectedRightException (String -> ExpectedRightException)
-> String -> ExpectedRightException
forall a b. (a -> b) -> a -> b
$ e -> String
forall a. Show a => a -> String
show e
e
rightOrError (Right a
a) = a -> m a
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a

-- | Convert an 'Either' value to a 'MonadFail' monad. This can be useful for converting
-- MonadThrow monads into Aeson Parser monads, but it loses the stack trace information.
toMonadFail :: (Exception e, MonadFail m) => Either e a -> m a
toMonadFail :: forall e (m :: * -> *) a.
(Exception e, MonadFail m) =>
Either e a -> m a
toMonadFail (Left e
e) = String -> m a
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m a) -> String -> m a
forall a b. (a -> b) -> a -> b
$ e -> String
forall e. Exception e => e -> String
displayException e
e
toMonadFail (Right a
a) = a -> m a
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a