module HaskellWorks.Polysemy.Error
  ( module HaskellWorks.Error,
    trap,
    trap_,
    runErrorMap,
    embedRunExceptT,
    embedThrowExceptT,
  ) where

import           Control.Monad.Except
import           HaskellWorks.Error
import           HaskellWorks.Polysemy.Prelude
import           Polysemy
import           Polysemy.Error

-- | Run a computation that may fail, and handle the error case.
-- Unlike 'catch' from 'Polysemy.Error' this function removes the 'Error'
-- effect from the stack.
trap :: forall e a r. ()
  => (e -> Sem r a)
  -> Sem (Error e ': r) a
  -> Sem r a
trap :: forall e a (r :: EffectRow).
(e -> Sem r a) -> Sem (Error e : r) a -> Sem r a
trap e -> Sem r a
h Sem (Error e : r) a
f =
  Sem (Error e : r) a -> Sem r (Either e a)
forall e (r :: EffectRow) a.
Sem (Error e : r) a -> Sem r (Either e a)
runError Sem (Error e : r) a
f Sem r (Either e a) -> (Either e a -> Sem r a) -> Sem r a
forall a b. Sem r a -> (a -> Sem r b) -> Sem r b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (e -> Sem r a) -> (a -> Sem r a) -> Either e a -> Sem r a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either e -> Sem r a
h a -> Sem r a
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

-- | Like 'trap', but the error is not passed to the handler.
trap_ :: forall e a r. ()
  => Sem r a
  -> Sem (Error e ': r) a
  -> Sem r a
trap_ :: forall e a (r :: EffectRow).
Sem r a -> Sem (Error e : r) a -> Sem r a
trap_ Sem r a
h =
  (e -> Sem r a) -> Sem (Error e : r) a -> Sem r a
forall e a (r :: EffectRow).
(e -> Sem r a) -> Sem (Error e : r) a -> Sem r a
trap (Sem r a -> e -> Sem r a
forall a b. a -> b -> a
const Sem r a
h)

-- | Run an 'Error' effect and map the error value to a different type.
runErrorMap :: ()
  => (e -> d)
  -> Sem (Error e : r) a
  -> Sem r (Either d a)
runErrorMap :: forall e d (r :: EffectRow) a.
(e -> d) -> Sem (Error e : r) a -> Sem r (Either d a)
runErrorMap e -> d
f =
  (Either e a -> Either d a)
-> Sem r (Either e a) -> Sem r (Either d a)
forall a b. (a -> b) -> Sem r a -> Sem r b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((e -> d) -> Either e a -> Either d 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 -> d
f) (Sem r (Either e a) -> Sem r (Either d a))
-> (Sem (Error e : r) a -> Sem r (Either e a))
-> Sem (Error e : r) a
-> Sem r (Either d a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sem (Error e : r) a -> Sem r (Either e a)
forall e (r :: EffectRow) a.
Sem (Error e : r) a -> Sem r (Either e a)
runError

embedRunExceptT :: forall e a r m. ()
  => Member (Embed m) r
  => ExceptT e m a
  -> Sem r (Either e a)
embedRunExceptT :: forall e a (r :: EffectRow) (m :: * -> *).
Member (Embed m) r =>
ExceptT e m a -> Sem r (Either e a)
embedRunExceptT = m (Either e a) -> Sem r (Either e a)
forall (m :: * -> *) (r :: EffectRow) a.
Member (Embed m) r =>
m a -> Sem r a
embed (m (Either e a) -> Sem r (Either e a))
-> (ExceptT e m a -> m (Either e a))
-> ExceptT e m a
-> Sem r (Either e a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExceptT e m a -> m (Either e a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT

-- | Run an embedded 'ExceptT' effect in a 'Sem' monad and throw any errors.
embedThrowExceptT :: forall e a r m. ()
  => Member (Error e) r
  => Member (Embed m) r
  => ExceptT e m a
  -> Sem r a
embedThrowExceptT :: forall e a (r :: EffectRow) (m :: * -> *).
(Member (Error e) r, Member (Embed m) r) =>
ExceptT e m a -> Sem r a
embedThrowExceptT ExceptT e m a
f =
  ExceptT e m a -> Sem r (Either e a)
forall e a (r :: EffectRow) (m :: * -> *).
Member (Embed m) r =>
ExceptT e m a -> Sem r (Either e a)
embedRunExceptT ExceptT e m a
f
    Sem r (Either e a) -> (Sem r (Either e a) -> Sem r a) -> Sem r a
forall a b. a -> (a -> b) -> b
& (e -> Sem r a) -> Sem r (Either e a) -> Sem r a
forall e a (m :: * -> *).
Monad m =>
(e -> m a) -> m (Either e a) -> m a
onLeftM e -> Sem r a
forall e (r :: EffectRow) a. Member (Error e) r => e -> Sem r a
throw