{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE UndecidableInstances #-}
module Control.Monad.CPSExcept where
import Control.Monad.Except
import Control.Monad.State
import Control.Monad.Reader()
import Control.Monad.Writer()
import Control.Monad.RWS()

newtype CPSExceptT e m a =
  CPSExceptT { CPSExceptT e m a -> forall r. (e -> m r) -> (a -> m r) -> m r
getCPSExceptT :: forall r. ((e -> m r) -> (a -> m r) -> m r) }

runCPSExceptT :: Applicative m => CPSExceptT e m a -> m (Either e a)
runCPSExceptT :: CPSExceptT e m a -> m (Either e a)
runCPSExceptT (CPSExceptT forall r. (e -> m r) -> (a -> m r) -> m r
f) = (e -> m (Either e a)) -> (a -> m (Either e a)) -> m (Either e a)
forall r. (e -> m r) -> (a -> m r) -> m r
f (Either e a -> m (Either e a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either e a -> m (Either e a))
-> (e -> Either e a) -> e -> m (Either e a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> Either e a
forall a b. a -> Either a b
Left)  (Either e a -> m (Either e a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either e a -> m (Either e a))
-> (a -> Either e a) -> a -> m (Either e a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Either e a
forall a b. b -> Either a b
Right)
{-# INLINE runCPSExceptT #-}

instance Functor (CPSExceptT e m) where
  fmap :: (a -> b) -> CPSExceptT e m a -> CPSExceptT e m b
fmap a -> b
f (CPSExceptT forall r. (e -> m r) -> (a -> m r) -> m r
g) = (forall r. (e -> m r) -> (b -> m r) -> m r) -> CPSExceptT e m b
forall e (m :: * -> *) a.
(forall r. (e -> m r) -> (a -> m r) -> m r) -> CPSExceptT e m a
CPSExceptT ((forall r. (e -> m r) -> (b -> m r) -> m r) -> CPSExceptT e m b)
-> (forall r. (e -> m r) -> (b -> m r) -> m r) -> CPSExceptT e m b
forall a b. (a -> b) -> a -> b
$ \e -> m r
failC b -> m r
successC ->
    (e -> m r) -> (a -> m r) -> m r
forall r. (e -> m r) -> (a -> m r) -> m r
g e -> m r
failC (b -> m r
successC (b -> m r) -> (a -> b) -> a -> m r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f)
  {-# INLINE fmap #-}

instance Monad m => Applicative (CPSExceptT e m) where
  pure :: a -> CPSExceptT e m a
pure a
x = (forall r. (e -> m r) -> (a -> m r) -> m r) -> CPSExceptT e m a
forall e (m :: * -> *) a.
(forall r. (e -> m r) -> (a -> m r) -> m r) -> CPSExceptT e m a
CPSExceptT ((forall r. (e -> m r) -> (a -> m r) -> m r) -> CPSExceptT e m a)
-> (forall r. (e -> m r) -> (a -> m r) -> m r) -> CPSExceptT e m a
forall a b. (a -> b) -> a -> b
$ \e -> m r
_failC a -> m r
successC -> a -> m r
successC a
x
  {-# INLINE pure #-}
  <*> :: CPSExceptT e m (a -> b) -> CPSExceptT e m a -> CPSExceptT e m b
(<*>) = CPSExceptT e m (a -> b) -> CPSExceptT e m a -> CPSExceptT e m b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap
  {-# INLINE (<*>) #-}

instance Monad m => Monad (CPSExceptT e m) where
  CPSExceptT forall r. (e -> m r) -> (a -> m r) -> m r
f >>= :: CPSExceptT e m a -> (a -> CPSExceptT e m b) -> CPSExceptT e m b
>>= a -> CPSExceptT e m b
g = (forall r. (e -> m r) -> (b -> m r) -> m r) -> CPSExceptT e m b
forall e (m :: * -> *) a.
(forall r. (e -> m r) -> (a -> m r) -> m r) -> CPSExceptT e m a
CPSExceptT ((forall r. (e -> m r) -> (b -> m r) -> m r) -> CPSExceptT e m b)
-> (forall r. (e -> m r) -> (b -> m r) -> m r) -> CPSExceptT e m b
forall a b. (a -> b) -> a -> b
$ \e -> m r
failC b -> m r
successC ->
    (e -> m r) -> (a -> m r) -> m r
forall r. (e -> m r) -> (a -> m r) -> m r
f e -> m r
failC (\a
a -> CPSExceptT e m b -> (e -> m r) -> (b -> m r) -> m r
forall e (m :: * -> *) a.
CPSExceptT e m a -> forall r. (e -> m r) -> (a -> m r) -> m r
getCPSExceptT (a -> CPSExceptT e m b
g a
a) e -> m r
failC b -> m r
successC)
  {-# INLINE (>>=) #-}

instance Monad m => MonadError e (CPSExceptT e m) where
  throwError :: e -> CPSExceptT e m a
throwError e
e = (forall r. (e -> m r) -> (a -> m r) -> m r) -> CPSExceptT e m a
forall e (m :: * -> *) a.
(forall r. (e -> m r) -> (a -> m r) -> m r) -> CPSExceptT e m a
CPSExceptT ((forall r. (e -> m r) -> (a -> m r) -> m r) -> CPSExceptT e m a)
-> (forall r. (e -> m r) -> (a -> m r) -> m r) -> CPSExceptT e m a
forall a b. (a -> b) -> a -> b
$ \e -> m r
failC a -> m r
_successC -> e -> m r
failC e
e
  {-# INLINE throwError #-}
  catchError :: CPSExceptT e m a -> (e -> CPSExceptT e m a) -> CPSExceptT e m a
catchError (CPSExceptT forall r. (e -> m r) -> (a -> m r) -> m r
f) e -> CPSExceptT e m a
handler =
    (forall r. (e -> m r) -> (a -> m r) -> m r) -> CPSExceptT e m a
forall e (m :: * -> *) a.
(forall r. (e -> m r) -> (a -> m r) -> m r) -> CPSExceptT e m a
CPSExceptT ((forall r. (e -> m r) -> (a -> m r) -> m r) -> CPSExceptT e m a)
-> (forall r. (e -> m r) -> (a -> m r) -> m r) -> CPSExceptT e m a
forall a b. (a -> b) -> a -> b
$ \e -> m r
failC a -> m r
successC ->
    (e -> m r) -> (a -> m r) -> m r
forall r. (e -> m r) -> (a -> m r) -> m r
f (\e
e -> CPSExceptT e m a -> (e -> m r) -> (a -> m r) -> m r
forall e (m :: * -> *) a.
CPSExceptT e m a -> forall r. (e -> m r) -> (a -> m r) -> m r
getCPSExceptT (e -> CPSExceptT e m a
handler e
e) e -> m r
failC a -> m r
successC)
    a -> m r
successC
  {-# INLINE catchError #-}

instance MonadTrans (CPSExceptT e) where
  lift :: m a -> CPSExceptT e m a
lift m a
m = (forall r. (e -> m r) -> (a -> m r) -> m r) -> CPSExceptT e m a
forall e (m :: * -> *) a.
(forall r. (e -> m r) -> (a -> m r) -> m r) -> CPSExceptT e m a
CPSExceptT ((forall r. (e -> m r) -> (a -> m r) -> m r) -> CPSExceptT e m a)
-> (forall r. (e -> m r) -> (a -> m r) -> m r) -> CPSExceptT e m a
forall a b. (a -> b) -> a -> b
$ \e -> m r
_failC a -> m r
successC -> m a
m m a -> (a -> m r) -> m r
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> m r
successC
  {-# INLINE lift #-}

instance MonadState s m => MonadState s (CPSExceptT e m) where
  state :: (s -> (a, s)) -> CPSExceptT e m a
state s -> (a, s)
f = m a -> CPSExceptT e m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> CPSExceptT e m a) -> m a -> CPSExceptT e m a
forall a b. (a -> b) -> a -> b
$ (s -> (a, s)) -> m a
forall s (m :: * -> *) a. MonadState s m => (s -> (a, s)) -> m a
state s -> (a, s)
f
  {-# INLINE state #-}