MapError.hs

{-# LANGUAGE DefaultSignatures      #-}
{-# LANGUAGE FlexibleInstances      #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE MultiParamTypeClasses  #-}
{-# LANGUAGE PartialTypeSignatures  #-}
{-# LANGUAGE TypeFamilies           #-}
{-# LANGUAGE UndecidableInstances   #-}

module MapError where

import           Control.Exception
import           Control.Monad.Except
import           Control.Monad.Morph
import           Control.Monad.Reader
import           Control.Monad.State
import           Control.Monad.Trans.Maybe
import           Control.Monad.Writer
import           Data.Bifunctor

type family Outer (tm :: * -> *) :: (* -> *) -> * -> * where
    Outer (t m) = t

type family Inner (tm :: * -> *) :: * -> * where
    Inner (t m) = m

type RecreateMonadTransError e e' m m' =
    Outer m (RecreateMonadError e e' (Inner m) (Inner m'))

class
    ( m' ~ RecreateMonadError e e' m m'
    , m ~ RecreateMonadError e' e m' m
    ) => SameModuloErrors e e' m m'

instance
    ( m' ~ RecreateMonadError e e' m m'
    , m ~ RecreateMonadError e' e m' m
    ) => SameModuloErrors e e' m m'

class MonadError e m => MapMonadError e m | m -> e where
    type NewError e' (m :: * -> *) :: *
    type RecreateMonadError e e' m (m' :: * -> *) :: * -> *
    type NewError e' m = NewError e' (Inner m)
    type RecreateMonadError e e' m m' = RecreateMonadTransError e e' m m'
    mapMonadError
        :: (SameModuloErrors e e' m m', e' ~ NewError e' m)
        => (e -> e') -> m a -> m' a
    default mapMonadError
        :: ( SameModuloErrors e e' m m', e' ~ NewError e' m
           , m ~ t n, MFunctor t, MapMonadError e n
           , NewError e' m ~ NewError e' (Inner m)
           , RecreateMonadError e e' m m' ~ RecreateMonadTransError e e' m m'
           , RecreateMonadError e' e m' m ~ RecreateMonadTransError e' e m' m
           )
        => (e -> e') -> m a -> m' a
    mapMonadError f = hoist (mapMonadError f)

class
    ( MapMonadError e m, MapMonadError e' m'
    , SameModuloErrors e e' m m', e' ~ NewError e' m
    ) => MonadErrorMapping e e' m m'

instance
    ( MapMonadError e m, MapMonadError e' m'
    , SameModuloErrors e e' m m', e' ~ NewError e' m
    ) => MonadErrorMapping e e' m m'

-- | A more inference-friendly version of 'mapMonadError'.
mapError :: MonadErrorMapping e e' m m' => (e -> e') -> m a -> m' a
mapError = mapMonadError

instance MapMonadError () Maybe where
    type NewError e' Maybe = ()
    type RecreateMonadError () e' Maybe m' = Maybe
    mapMonadError = const id

instance MapMonadError IOException IO where
    type NewError e' IO = IOException
    type RecreateMonadError IOException e' IO m' = IO
    mapMonadError f a = a `catch` (throw . f)

instance MapMonadError e (Either e) where
    type NewError e' (Either e) = e'
    type RecreateMonadError e e' (Either e) m' = Either e'
    mapMonadError = first

instance Monad m => MapMonadError e (ExceptT e m) where
    type NewError e' (ExceptT e m) = e'
    type RecreateMonadError e e' (ExceptT e m) m' = ExceptT e' m
    mapMonadError = withExceptT

instance MapMonadError e m => MapMonadError e (ReaderT r m)
instance (MapMonadError e m, Monoid w) => MapMonadError e (WriterT w m)
instance MapMonadError e m => MapMonadError e (StateT s m)

-- Everything is inferred well.

test01 :: (_ -> _) -> Maybe _ -> _
test01 = mapError

test02 :: (_ -> _) -> _ -> Maybe _
test02 = mapError

test11 :: (_ -> _) -> ReaderT _ (ExceptT _ (State _)) _ -> _
test11 = mapError

test12 :: (_ -> _) -> _ -> ReaderT _ (ExceptT _ (State _)) _
test12 = mapError

test31 :: (_ -> _) -> IO a -> _
test31 = mapError

test32 :: (_ -> _) -> _ -> IO a
test32 = mapError

test1 :: (e -> e') -> ReaderT r (ExceptT e (State s)) a -> ReaderT r (ExceptT e' (State s)) a
test1 = mapError

test3
    :: (MonadErrorMapping e e' m m', MonadReader r m)
    => (e -> e')
    -> m ()
    -> m' r
test3 f a = mapError f $ a *> ask

data R = R
data E1 = E1 deriving (Show)
data E2 = E2 E1 deriving (Show)

runStuff :: ExceptT E2 (Reader R) a -> Either E2 a
runStuff a = runReader (runExceptT a) R

test4 :: Either E2 Char
test4 = runStuff (mapError E2 $ throwError E1)