{-# LANGUAGE GADTs           #-}
{-# LANGUAGE TemplateHaskell #-}

-- | Description: The 'Except' effect, providing catch and throw functionality over the final
-- monad via MonadCatch.
module HaskellWorks.Polysemy.Except
  ( -- * Effect
    Except (..),

    -- * Actions
    catchEx,
    throwEx,

    -- * Interpretations
    catchExToFinal,
    catchExToFinalIO,
  ) where

import           Control.Exception    (Exception (..))
import qualified Control.Monad.Catch  as X
import           HaskellWorks.Prelude
import           Polysemy
import           Polysemy.Final

------------------------------------------------------------------------------
-- | An effect capable of providing 'X.catch' and 'X.throwM' semantics. Interpreters for
-- this will successfully run the catch the exceptions thrown in the IO monad.
data Except m a where
  CatchEx
    :: Exception e
    => m a
    -> (e -> m a)
    -> Except m a

  ThrowEx
    :: Exception e
    => e
    -> Except m a

makeSem ''Except

------------------------------------------------------------------------------
-- | Run a 'Except' effect in terms of 'X.catch' and 'X.throwM' through final monad.
--
-- /Beware/: Effects that aren't interpreted in terms of 'IO'
-- will have local state semantics in regards to 'Except' effects
-- interpreted this way. See 'Final'.
catchExToFinal :: forall a r m. ()
  => X.MonadCatch m
  => X.MonadThrow m
  => Member (Final m) r
  => Sem (Except ': r) a
  -> Sem r a
catchExToFinal :: forall a (r :: EffectRow) (m :: * -> *).
(MonadCatch m, MonadThrow m, Member (Final m) r) =>
Sem (Except : r) a -> Sem r a
catchExToFinal = (forall x (rInitial :: EffectRow).
 Except (Sem rInitial) x -> Strategic m (Sem rInitial) x)
-> Sem (Except : r) a -> Sem r a
forall (m :: * -> *) (e :: Effect) (r :: EffectRow) a.
Member (Final m) r =>
(forall x (rInitial :: EffectRow).
 e (Sem rInitial) x -> Strategic m (Sem rInitial) x)
-> Sem (e : r) a -> Sem r a
interpretFinal ((forall x (rInitial :: EffectRow).
  Except (Sem rInitial) x -> Strategic m (Sem rInitial) x)
 -> Sem (Except : r) a -> Sem r a)
-> (forall x (rInitial :: EffectRow).
    Except (Sem rInitial) x -> Strategic m (Sem rInitial) x)
-> Sem (Except : r) a
-> Sem r a
forall a b. (a -> b) -> a -> b
$ \case
  CatchEx Sem rInitial x
f e -> Sem rInitial x
h -> do
    f ()
s  <- Sem (WithStrategy m f (Sem rInitial)) (f ())
forall (m :: * -> *) (f :: * -> *) (n :: * -> *).
Sem (WithStrategy m f n) (f ())
getInitialStateS
    m (f x)
a  <- Sem rInitial x -> Sem (WithStrategy m f (Sem rInitial)) (m (f x))
forall (n :: * -> *) a (m :: * -> *) (f :: * -> *).
n a -> Sem (WithStrategy m f n) (m (f a))
runS Sem rInitial x
f
    f e -> m (f x)
h' <- (e -> Sem rInitial x)
-> Sem (WithStrategy m f (Sem rInitial)) (f e -> m (f x))
forall a (n :: * -> *) b (m :: * -> *) (f :: * -> *).
(a -> n b) -> Sem (WithStrategy m f n) (f a -> m (f b))
bindS e -> Sem rInitial x
h
    m (f x) -> Sem (WithStrategy m f (Sem rInitial)) (m (f x))
forall a. a -> Sem (WithStrategy m f (Sem rInitial)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (m (f x) -> Sem (WithStrategy m f (Sem rInitial)) (m (f x)))
-> m (f x) -> Sem (WithStrategy m f (Sem rInitial)) (m (f x))
forall a b. (a -> b) -> a -> b
$ m (f x) -> (e -> m (f x)) -> m (f x)
forall e a. (HasCallStack, Exception e) => m a -> (e -> m a) -> m a
forall (m :: * -> *) e a.
(MonadCatch m, HasCallStack, Exception e) =>
m a -> (e -> m a) -> m a
X.catch m (f x)
a ((e -> m (f x)) -> m (f x)) -> (e -> m (f x)) -> m (f x)
forall a b. (a -> b) -> a -> b
$ \e
e -> f e -> m (f x)
h' (f e -> m (f x)) -> f e -> m (f x)
forall a b. (a -> b) -> a -> b
$ e
e e -> f () -> f e
forall a b. a -> f b -> f a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ f ()
s
  ThrowEx e
e ->
    m (f x) -> Sem (WithStrategy m f (Sem rInitial)) (m (f x))
forall a. a -> Sem (WithStrategy m f (Sem rInitial)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (m (f x) -> Sem (WithStrategy m f (Sem rInitial)) (m (f x)))
-> m (f x) -> Sem (WithStrategy m f (Sem rInitial)) (m (f x))
forall a b. (a -> b) -> a -> b
$ e -> m (f x)
forall e a. (HasCallStack, Exception e) => e -> m a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
X.throwM e
e
{-# INLINE catchExToFinal #-}

------------------------------------------------------------------------------
-- | Run a 'Except' effect in terms of 'X.catch' and 'X.throwM' through final IO monad.
catchExToFinalIO :: forall a r. ()
  => Member (Final IO) r
  => Sem (Except ': r) a
  -> Sem r a
catchExToFinalIO :: forall a (r :: EffectRow).
Member (Final IO) r =>
Sem (Except : r) a -> Sem r a
catchExToFinalIO = Sem (Except : r) a -> Sem r a
forall a (r :: EffectRow) (m :: * -> *).
(MonadCatch m, MonadThrow m, Member (Final m) r) =>
Sem (Except : r) a -> Sem r a
catchExToFinal
{-# INLINE catchExToFinalIO #-}