{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}

-- | This module serves purpose as a single source of abstractions used in handling 'MonadError' and
-- 'ExceptT' through 'cardano-api'.
module Cardano.Api.Monad.Error
  ( MonadTransError
  , MonadIOTransError
  , liftExceptT
  , modifyError
  , handleIOExceptionsWith
  , handleIOExceptionsLiftWith
  , hoistIOEither
  , liftMaybe
  , module Control.Monad.Except
  , module Control.Monad.IO.Class
  , module Control.Monad.Trans.Class
  , module Control.Monad.Trans.Except
  , module Control.Monad.Trans.Except.Extra
  )
where

import           Control.Exception.Safe
import           Control.Monad.Except (ExceptT (..), MonadError (..), catchError, liftEither,
                   mapExcept, mapExceptT, runExcept, runExceptT, withExcept)
import           Control.Monad.IO.Class
import           Control.Monad.Trans.Class
import           Control.Monad.Trans.Except
import           Control.Monad.Trans.Except.Extra
import           Data.Bifunctor (first)

-- | Convenience alias
type MonadTransError e t m = (Monad m, MonadTrans t, MonadError e (t m))

--

-- | Same as 'MonadTransError', but with also 'MonadIO' constraint
type MonadIOTransError e t m =
  (MonadIO m, MonadIO (t m), MonadCatch m, MonadTrans t, MonadError e (t m))

-- | Modify an 'ExceptT' error and lift it to 'MonadError' transformer stack.
--
-- This implementation avoids nesting problem of @modifyError@ from 'mtl'. The issue with @modifyError@ (from
-- 'mtl') is that when you use it on a function, you actually end up with @ExceptT e1 (ExceptT e2 m a)@:
--
-- > modifyError (f :: e2 -> e1) (foo :: ExceptT e2 (ExceptT e1 m) a) :: ExceptT e1 m a
--
-- and if you use @modifyError@ ('mtl') again, the more nested you get e.g.
-- @ExceptT e1 (ExceptT e2 (ExceptT e3 m a))@. With a deeper monad stack you pay the overhead with every
-- use of '>>='.
--
-- This function avoids that, but at the cost of limiting its application to transformers.
modifyError
  :: MonadTransError e' t m
  => (e -> e')
  -- ^ mapping function
  -> ExceptT e m a
  -- ^ value
  -> t m a
  -- ^ result with modified error
modifyError :: forall e' (t :: (* -> *) -> * -> *) (m :: * -> *) e a.
MonadTransError e' t m =>
(e -> e') -> ExceptT e m a -> t m a
modifyError e -> e'
f ExceptT e m a
m = m (Either e a) -> t m (Either e a)
forall (m :: * -> *) a. Monad m => m a -> t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ExceptT e m a -> m (Either e a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT ExceptT e m a
m) t m (Either e a) -> (Either e a -> t m a) -> t m a
forall a b. t m a -> (a -> t m b) -> t m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (e -> t m a) -> (a -> t m a) -> Either e a -> t m a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (e' -> t m a
forall a. e' -> t m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (e' -> t m a) -> (e -> e') -> e -> t m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> e'
f) a -> t m a
forall a. a -> t m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

-- | Wrap an exception and lift it into 'MonadError'.
handleIOExceptionsWith
  :: MonadError e' m
  => MonadCatch m
  => Exception e
  => (e -> e')
  -- ^ mapping function
  -> m a
  -- ^ action that can throw
  -> m a
  -- ^ result with caught exception
handleIOExceptionsWith :: forall e' (m :: * -> *) e a.
(MonadError e' m, MonadCatch m, Exception e) =>
(e -> e') -> m a -> m a
handleIOExceptionsWith e -> e'
f m a
act = Either e' a -> m a
forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither (Either e' a -> m a)
-> (Either e a -> Either e' a) -> Either e a -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (e -> e') -> Either e a -> Either e' a
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first e -> e'
f (Either e a -> m a) -> m (Either e a) -> m a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< m a -> m (Either e a)
forall (m :: * -> *) e a.
(HasCallStack, MonadCatch m, Exception e) =>
m a -> m (Either e a)
try m a
act

-- | Wrap an exception and lift it into 'MonadError' stack.
handleIOExceptionsLiftWith
  :: MonadIOTransError e' t m
  => Exception e
  => (e -> e')
  -- ^ mapping function
  -> m a
  -- ^ action that can throw
  -> t m a
  -- ^ action with caught error lifted into 'MonadError' stack
handleIOExceptionsLiftWith :: forall e' (t :: (* -> *) -> * -> *) (m :: * -> *) e a.
(MonadIOTransError e' t m, Exception e) =>
(e -> e') -> m a -> t m a
handleIOExceptionsLiftWith e -> e'
f m a
act = Either e' a -> t m a
forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither (Either e' a -> t m a) -> t m (Either e' a) -> t m a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< m (Either e' a) -> t m (Either e' a)
forall (m :: * -> *) a. Monad m => m a -> t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift ((e -> e') -> Either e a -> Either e' a
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first e -> e'
f (Either e a -> Either e' a) -> m (Either e a) -> m (Either e' a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m a -> m (Either e a)
forall (m :: * -> *) e a.
(HasCallStack, MonadCatch m, Exception e) =>
m a -> m (Either e a)
try m a
act)

-- | Lift 'ExceptT' into 'MonadTransError'
liftExceptT
  :: MonadTransError e t m
  => ExceptT e m a
  -> t m a
liftExceptT :: forall e (t :: (* -> *) -> * -> *) (m :: * -> *) a.
MonadTransError e t m =>
ExceptT e m a -> t m a
liftExceptT = (e -> e) -> ExceptT e m a -> t m a
forall e' (t :: (* -> *) -> * -> *) (m :: * -> *) e a.
MonadTransError e' t m =>
(e -> e') -> ExceptT e m a -> t m a
modifyError e -> e
forall a. a -> a
id

-- | Lift an 'IO' action that returns 'Either' into 'MonadIOTransError'
hoistIOEither
  :: MonadIOTransError e t m
  => IO (Either e a)
  -> t m a
hoistIOEither :: forall e (t :: (* -> *) -> * -> *) (m :: * -> *) a.
MonadIOTransError e t m =>
IO (Either e a) -> t m a
hoistIOEither = ExceptT e m a -> t m a
forall e (t :: (* -> *) -> * -> *) (m :: * -> *) a.
MonadTransError e t m =>
ExceptT e m a -> t m a
liftExceptT (ExceptT e m a -> t m a)
-> (IO (Either e a) -> ExceptT e m a) -> IO (Either e a) -> t m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m (Either e a) -> ExceptT e m a
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (m (Either e a) -> ExceptT e m a)
-> (IO (Either e a) -> m (Either e a))
-> IO (Either e a)
-> ExceptT e m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO (Either e a) -> m (Either e a)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO

-- | Lift 'Maybe' into 'MonadError'
liftMaybe
  :: MonadError e m
  => e
  -- ^ Error to throw, if 'Nothing'
  -> Maybe a
  -> m a
liftMaybe :: forall e (m :: * -> *) a. MonadError e m => e -> Maybe a -> m a
liftMaybe e
e = m a -> (a -> m a) -> Maybe a -> m a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (e -> m a
forall a. e -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError e
e) a -> m a
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure