Deriving MTL classes using -XDerivingVia

MTLDerivingVia.hs

-- |
  -- Module      :  Lift
  -- Copyright   :  (c) Reed Mullanix 2019
  -- License     :  BSD-style
  -- Maintainer  :  [email protected]
  --
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE RankNTypes #-}

{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
  module Lift
  (
  ) where

import Control.Applicative
import Control.Monad
import Control.Monad.Identity
import Control.Monad.Fix
import Control.Monad.Fail
import Control.Monad.Trans
import Control.Monad.IO.Class
import Control.Monad.RWS.Class
import Control.Monad.Cont.Class

import Control.Monad.Reader
import Control.Monad.Writer
import Control.Monad.State
import Control.Monad.Except


newtype Inner (t :: (* -> *) -> * -> *) m a = Inner { getInner :: t m a }
  deriving (Functor, Applicative, Monad)

liftInner :: (Monad m, Monad (t m), MonadTrans t) => m a -> Inner t m a
liftInner = Inner . lift

mapInner :: (Monad m, Monad (t m), MonadTrans t) => (m a -> m b) -> Inner t m a -> Inner t m b
mapInner f (Inner tma) = Inner $ tma >>= lift . f . return


instance (MonadReader r m) => MonadReader r (Inner (ReaderT r') m) where
  ask = liftInner ask
  local f = mapInner (local f)

instance (MonadState s m) => MonadState s (Inner (StateT s') m) where
  get = Inner $ lift get
  put = Inner . lift . put

instance (MonadWriter w m, Monoid w') => MonadWriter w (Inner (WriterT w') m) where
  tell = liftInner . tell
  listen = mapInner listen
  pass = mapInner pass

instance (MonadError e m) => MonadError e (Inner (ExceptT e') m) where
  throwError = liftInner . throwError
  catchError (Inner (ExceptT m)) handler = Inner $ ExceptT $ catchError m (runExceptT . getInner . handler)

---------------------[EXAMPLES]--------------------
newtype FreshT m a = FreshT { unFreshT :: StateT Int m a }
  deriving newtype (Functor, Applicative, Monad, MonadReader r)
  deriving (MonadState s) via Inner (StateT Int) m

newtype FooT s e m a = FooT { unFooT :: StateT s (WriterT String (ExceptT e m)) a }
  deriving newtype (Functor, Applicative, Monad, MonadError e)
  deriving (MonadWriter w) via (StateT s (Inner (WriterT String) (ExceptT e m)))
  deriving (MonadState s') via Inner (StateT s) (WriterT String (ExceptT e m))