WithMonadError.hs

{-# LANGUAGE ConstraintKinds         #-}
{-# LANGUAGE FlexibleContexts        #-}
{-# LANGUAGE FlexibleInstances       #-}
{-# LANGUAGE FunctionalDependencies  #-}
{-# LANGUAGE InstanceSigs            #-}
{-# LANGUAGE MultiParamTypeClasses   #-}
{-# LANGUAGE RankNTypes              #-}
{-# LANGUAGE ScopedTypeVariables     #-}
{-# LANGUAGE TypeFamilies            #-}
{-# LANGUAGE TypeOperators           #-}
{-# LANGUAGE UndecidableInstances    #-}
{-# LANGUAGE UndecidableSuperClasses #-}

import           Control.Monad.Reader
import           Control.Monad.Trans.Class
import           Control.Monad.Trans.Except
import           Data.Proxy
import           GHC.Exts                   (Constraint)


class (n ~ SetError o m, m ~ SetError e n) => SameModuloError e m o n
instance (n ~ SetError o m, m ~ SetError e n) => SameModuloError e m o n

class (SetError e m ~ m, Monad m) => MonadError e m | m -> e where
    type SetError o m :: * -> *

    throwError :: e -> m a
    catchError :: (SameModuloError e m o n, MonadError o n) => m a -> (e -> n a) -> n a

    withSetError
        :: MonadError e m
        => Proxy (m o) -> ((SetError e (SetError o m) ~ m, MonadError o (SetError o m)) => c) -> c

withMonadError
    :: (SameModuloError e m o n, MonadError e m, MonadError o n)
    => (e -> o) -> m a -> n a
withMonadError f a = a `catchError` (throwError . f)

peelTrans :: Proxy (t m a) -> Proxy (m a)
peelTrans _ = Proxy

instance MonadError e (Either e) where
    type SetError o (Either e) = Either o

    throwError = Left
    catchError a f = either f return a

    withSetError _ c = c

instance Monad m => MonadError e (ExceptT e m) where
    type SetError o (ExceptT e m) = ExceptT o m

    throwError = throwE
    catchError (ExceptT a) f = ExceptT $ a >>= either (runExceptT . f) (return . return)

    withSetError _ c = c

instance MonadError e m => MonadError e (ReaderT r m) where
    type SetError o (ReaderT r m) = ReaderT r (SetError o m)

    throwError = lift . throwError

    catchError
        :: forall o n a. (SameModuloError e (ReaderT r m) o n, MonadError o n)
        => ReaderT r m a -> (e -> n a) -> n a
    catchError (ReaderT k) f =
        ReaderT $ \r -> withSetError (Proxy :: Proxy (m o)) $ k r `catchError` \e -> runReaderT (f e) r

    withSetError proxy = withSetError (peelTrans proxy)



data Env = Env
data Err1 = Err1
newtype Err2 = Err2 Err1

type SomethingM e a = ReaderT Env (Either e) a

doSomething1 :: SomethingM Err1 a
doSomething1 = undefined

doSomething2 :: SomethingM Err2 a
doSomething2 = withMonadError Err2 doSomething1

type DoingSomething e m = (MonadReader Env m, MonadError e m)

doSomethingExtensible1 :: DoingSomething Err1 m => m a
doSomethingExtensible1 = undefined

doSomethingExtensible2
    :: ( DoingSomething Err2 m
       , SetError Err2 (SetError Err1 m) ~ m
       , MonadError Err1 (SetError Err1 m)
       , MonadReader Env (SetError Err1 m)
       )
    => m a
doSomethingExtensible2 = withMonadError Err2 doSomethingExtensible1

doSomethingExtensible2' :: forall m a. (DoingSomething Err2 m, MonadReader Env (SetError Err1 m)) => m a
doSomethingExtensible2' = withSetError (Proxy :: Proxy (m Err1)) doSomethingExtensible2