{-# LANGUAGE ExistentialQuantification, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, TypeOperators, UndecidableInstances #-}
module Control.Carrier.Resumable.Either
(
runResumable
, ResumableC(..)
, SomeError(..)
, module Control.Effect.Resumable
) where
import Control.Applicative (Alternative(..))
import Control.Algebra
import Control.Carrier.Error.Either
import Control.DeepSeq
import Control.Effect.Resumable
import Control.Monad (MonadPlus(..))
import qualified Control.Monad.Fail as Fail
import Control.Monad.Fix
import Control.Monad.IO.Class
import Control.Monad.Trans.Class
import Data.Functor.Classes
runResumable :: ResumableC err m a -> m (Either (SomeError err) a)
runResumable = runError . runResumableC
newtype ResumableC err m a = ResumableC { runResumableC :: ErrorC (SomeError err) m a }
deriving (Alternative, Applicative, Functor, Monad, Fail.MonadFail, MonadFix, MonadIO, MonadPlus, MonadTrans)
instance (Algebra sig m, Effect sig) => Algebra (Resumable err :+: sig) (ResumableC err m) where
alg (L (Resumable err _)) = ResumableC (throwError (SomeError err))
alg (R other) = ResumableC (alg (R (handleCoercible other)))
{-# INLINE alg #-}
data SomeError err
= forall a . SomeError (err a)
instance Eq1 err => Eq (SomeError err) where
SomeError exc1 == SomeError exc2 = liftEq (const (const True)) exc1 exc2
instance Ord1 err => Ord (SomeError err) where
SomeError exc1 `compare` SomeError exc2 = liftCompare (const (const EQ)) exc1 exc2
instance Show1 err => Show (SomeError err) where
showsPrec d (SomeError err) = showsUnaryWith (liftShowsPrec (const (const id)) (const id)) "SomeError" d err
instance NFData1 err => NFData (SomeError err) where
rnf (SomeError err) = liftRnf (\a -> seq a ()) err