# LANGUAGE FlexibleInstances #
# LANGUAGE GeneralizedNewtypeDeriving #
# LANGUAGE MultiParamTypeClasses #
# LANGUAGE TypeOperators #
# LANGUAGE UndecidableInstances #
module Control.Carrier.Error.IO
( -- * Error carrier
  runError
, ErrorC(ErrorC)
  -- * Error effect
, module Control.Effect.Error
) where

import Control.Algebra
import Control.Effect.Error
import Control.Effect.Lift
import Control.Exception.Lift
import Control.Monad.IO.Class
import Control.Monad.Trans.Class

runError :: (Exception e, Has (Lift IO) sig m) => ErrorC e m a -> m (Either e a)
runError (ErrorC m) = try m

newtype ErrorC e m a = ErrorC { runErrorC :: m a }
  deriving (Applicative, Functor, Monad, MonadFail, MonadIO)

instance MonadTrans (ErrorC e) where
  lift = ErrorC

instance (Exception e, Has (Lift IO) sig m) => Algebra (Error e :+: sig) (ErrorC e m) where
  alg hdl sig ctx = case sig of
    L (L (Throw e))   -> throwIO e
    L (R (Catch m h)) -> hdl (m <$ ctx) `catch` (hdl . (<$ ctx) . h)
    R other           -> ErrorC (alg (runErrorC . hdl) other ctx)

 * Error carrier
 * Error effect
# LANGUAGE FlexibleInstances #
# LANGUAGE GeneralizedNewtypeDeriving #
# LANGUAGE MultiParamTypeClasses #
# LANGUAGE TypeOperators #
# LANGUAGE UndecidableInstances #
module Control.Carrier.Error.IO
  runError
, ErrorC(ErrorC)
, module Control.Effect.Error
) where

import Control.Algebra
import Control.Effect.Error
import Control.Effect.Lift
import Control.Exception.Lift
import Control.Monad.IO.Class
import Control.Monad.Trans.Class

runError :: (Exception e, Has (Lift IO) sig m) => ErrorC e m a -> m (Either e a)
runError (ErrorC m) = try m

newtype ErrorC e m a = ErrorC { runErrorC :: m a }
  deriving (Applicative, Functor, Monad, MonadFail, MonadIO)

instance MonadTrans (ErrorC e) where
  lift = ErrorC

instance (Exception e, Has (Lift IO) sig m) => Algebra (Error e :+: sig) (ErrorC e m) where
  alg hdl sig ctx = case sig of
    L (L (Throw e))   -> throwIO e
    L (R (Catch m h)) -> hdl (m <$ ctx) `catch` (hdl . (<$ ctx) . h)
    R other           -> ErrorC (alg (runErrorC . hdl) other ctx)
