'mtl' classes with mappable errors

Main.hs

{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wall #-}
{-# OPTIONS_GHC -Wno-partial-type-signatures #-}

module Main where

import Control.Monad (forM_)
import Control.Monad.Except (ExceptT, MonadError (..), mapExceptT, runExcept, runExceptT)
import Control.Monad.State (MonadState (..), StateT (..), mapStateT, modify, runState)
import Data.Bifunctor (Bifunctor (..))

class
  (MonadError e m, MonadError e' m') =>
  MappableError (e' :: *) (m' :: * -> *) (e :: *) (m :: * -> *)
    | m -> e,
      m' -> e',
      e m' -> m,
      e' m -> m'
  where
  mapError :: forall a. (e' -> e) -> m' a -> m a

instance Monad m => MappableError e' (ExceptT e' m) e (ExceptT e m) where
  mapError f = mapExceptT (fmap $ first f)

instance MappableError e' m' e m => MappableError e' (StateT s m') e (StateT s m) where
  mapError f = mapStateT (mapError f)

newtype FooErr = EvenFooCall Int
  deriving (Show)

foo :: (MonadState Int m, MonadError FooErr m) => m String
foo = do
  n <- get
  if even n
    then throwError $ EvenFooCall n
    else do
      modify succ
      return $ show n

newtype BarErr = BarOddCall Int
  deriving (Show)

bar :: (MonadState Int m, MonadError BarErr m) => m String
bar = do
  n <- get
  if odd n
    then throwError $ BarOddCall n
    else do
      modify pred
      return $ show n

data FooBarErr = FooErr FooErr | BarErr BarErr
  deriving (Show)

foobar :: _ => m String
foobar = do
  x <- get
  fooRes <- mapError FooErr foo
  modify (+ x `div` 2)
  barRes <- mapError BarErr bar
  return $ unwords [fooRes, barRes]

main :: IO ()
main = forM_ [1 .. 5] $ \n -> do
  print n
  print . flip runState n . runExceptT $ foobar
  print . runExcept . flip runStateT n $ foobar
  putStrLn ""