A variant of my FunDay-based composable handlers which is compatible with ExceptT and friends.

Handler.hs

-- A variant of https://gist.github.com/gelisam/d9b067a1ef78670d6e4c67b18740bbea
-- which suports ExceptT. Kind of.
{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, PolyKinds, RankNTypes, TupleSections, TypeOperators, UndecidableInstances #-}
module Main where
import Test.DocTest

import Control.Monad.Except
import Control.Monad.Reader
import Control.Monad.State
import Control.Monad.Writer
import Data.Functor.Const
import Data.Functor.Identity
import GHC.Generics ((:+:)(L1, R1), U1(U1))


-- Let me begin by repeating the demo from last time, to demonstrate that this
-- variant is just as powerful as my earlier FunDay-based variant. We start
-- with a computation which uses many effects...
myRWST :: ( MonadReader String m
          , MonadWriter String m
          , MonadState String m
          )
       => m String
myRWST = do
  r <- ask
  tell "w"
  modify (++ "'")
  pure (r ++ "esult")

-- |
-- The normal way to interpret them is by composing many "run" functions...
--
-- >>> runMyRWST
-- "result, w, s'"
--
-- The result is some tuple of values, but it's not immediately obvious which
-- part of the tuple corresponds to which run function...
runMyRWST :: Monad m
          => m String
runMyRWST = do
  ((s1, s2), s3) <- flip runStateT "s" . runWriterT . flip runReaderT "r" $ myRWST
  pure (s1 ++ ", " ++ s2 ++ ", " ++ s3)

-- |
-- ...whereas with my approch, it is obvious, because each handler (yes, I call
-- them handlers now) returns a single value, not a tuple of values. The
-- computation itself returns its own value. We can then combine all of the
-- values using Applicative syntax.
--
-- >>> handleMyRWST
-- "result, w, s'"
handleMyRWST :: Monad m
             => m String
handleMyRWST = runSimpleHandler
             $ (\() w s result -> result ++ ", " ++ w ++ ", " ++ s)
          <$$> handleReaderT "r"
          <**> handleWriterT
          <**> handleStateT "s"
          <**> computation myRWST


-- All right, that was the simple case, as is evidenced by the name
-- 'runSimpleHandler'. These cases are simple because 'ReaderT', 'WriterT' and
-- 'StateT' always returns a result. 'MaybeT' and 'ExceptT', however, are more
-- complicated because the allow the computation to abort before returning a
-- result. Let's write a computation which uses those effects.
myRMWEST :: ( MonadReader String m
            , MonadMaybe m
            , MonadWriter String m
            , MonadError String m
            , MonadState String m
            )
         => m String
myRMWEST = do
  r <- ask
  when (r /= "r") $ do
    nothing
  tell "w"
  when (r /= "r") $ do
    throwError "e"
  modify (++ "'")
  pure (r ++ "esult")

-- |
-- The normal way to interpret these effects is, again, by composing many run
-- functions. This time however, we don't get a tuple: we get some more
-- complicated combination of 'Either', 'Maybe', and tuples.
--
-- >>> runMyRMWEST
-- "result, w, s'"
runMyRMWEST :: Monad m
            => m String
runMyRMWEST = do
  r <- flip runStateT "s" . runExceptT . runWriterT . runMaybeT . flip runReaderT "r" $ myRMWEST
  case r of
    (Left e, s)                 -> pure (e ++ ", " ++ s)
    (Right (Nothing, w), s)     -> pure (w ++ ", " ++ s)
    (Right (Just result, w), s) -> pure (result ++ ", " ++ w ++ ", " ++ s)

-- |
-- There's no way out of it, the result will have to be a complicated
-- combination of 'Either's and 'Maybe's. But with this variant, we can now
-- continue to combine the results of the tuple part using the nice indexed
-- Applicative syntax, even though there are some fancier effects which don't
-- use tuples in-between.
--
-- >>> handleMyRWEST
-- "result, w, s'"
handleMyRWEST :: Monad m
              => m String
handleMyRWEST = do
  r <- runHandler $ (\() () w () s result -> result ++ ", " ++ w ++ ", " ++ s)
               <$$> handleReaderT "r"
               <**> handleMaybeT
               <**> handleWriterT
               <**> handleExceptT
               <**> handleStateT "s"
               <**> computation myRWST
  -- Ideally 'r' would be a @Maybe (Either String String)@, but instead it is
  -- the isomorphic type @(U1 :+: (Const String :+: Identity)) String@. I think
  -- there's a way around this, but one step at a time :)
  case r of
    L1 U1                -> pure ""
    R1 (L1 (Const e))    -> pure e
    R1 (R1 (Identity s)) -> pure s


-- All right, so what's the trick? More type parameters!! Previously, FunDay
-- was indexed by 'm', 'n' and 'a'. In this version, I am throwing in two more,
-- 'f' and 'g', both of which will be instantiated by something like
-- @Const String :+: Identity@. As 'm' becomes a smaller 'n' which has fewer
-- layers it its monad transformer stack, 'f' becomes a larger 'g' which has
-- more branches, to represent the 'Nothing' and 'Left' cases as they are
-- encountered.

newtype Handler m n f g a = Handler
  { unHandler :: forall x y. (a -> x -> y) -> m (f x) -> n (g y) }

-- The simple handlers are just as easy to implement as before; they don't add
-- any branches to the 'f', so the 'f' is the same before and after 'm' has
-- been transformed to an 'n'. We previously had to use the 'l' to transform
-- the @x@ into a @y@; now we have to use this same 'l' to transform an @f x@
-- into an @f y@, which we can do easily if 'f' is a Functor.

computation :: (Applicative m, Functor f)
            => m a -> Handler m m f f a
computation ma = Handler (\l mfx -> (\a fx -> l a <$> fx) <$> ma <*> mfx)

handleReaderT :: (Monad m, Functor f)
              => r -> Handler (ReaderT r m) m f f ()
handleReaderT r = Handler $ \l ccFX -> do
  fx <- runReaderT ccFX r
  pure (l () <$> fx)

handleWriterT :: (Monad m, Functor f)
              => Handler (WriterT w m) m f f w
handleWriterT = Handler $ \l ccFX -> do
  (fx, w) <- runWriterT ccFX
  pure (l w <$> fx)

handleStateT :: (Monad m, Functor f)
             => s -> Handler (StateT s m) m f f s
handleStateT s = Handler $ \l ccFX -> do
  (fx, s') <- runStateT ccFX s
  pure (l s' <$> fx)

-- The non-simple handlers aren't that much more complicated; if we get a
-- result, we can apply 'l', otherwise we can't, so we have to return something
-- like a 'Left'. By extending the 'f' into a larger 'g' with more branches, we
-- can manufacture a @g y@ out of thin air, by using a branch which contains no
-- 'y's.

handleExceptT :: (Monad m, Functor f)
              => Handler (ExceptT e m) m f (Const e :+: f) ()
handleExceptT = Handler $ \l ccFX -> do
  r <- runExceptT ccFX
  case r of
    Left e   -> pure $ L1 (Const e)
    Right fx -> pure $ R1 (l () <$> fx)

handleMaybeT :: (Monad m, Functor f)
             => Handler (MaybeT m) m f (U1 :+: f) ()
handleMaybeT = Handler $ \l ccFX -> do
  r <- runMaybeT ccFX
  case r of
    Nothing -> pure $ L1 U1
    Just fx -> pure $ R1 (l () <$> fx)

-- The indexed Applicative instance is exactly the same as before, its only the
-- typeclass which is a bit more complicated because the type has more indices.

infixl 4 <$$>
infixl 4 <**>
class IxIxApplicative t where
  (<$$>) :: (a -> b) -> t m n f g a -> t m n f g b

  -- The two sets of indices both compose:
  -- (.) :: (m -> n) -> (l -> m) -> (l -> n)
  -- (.) :: (g -> h) -> (f -> g) -> (f -> h)
  (<**>) :: t m n g h (a -> b) -> t l m f g a -> t l n f h b

instance IxIxApplicative Handler where
  a2b <$$> handlerA = Handler $ \l ccFX
                   -> unHandler handlerA (go l)
                    $ ccFX
    where go l a x = l (a2b a) x
  handlerF <**> handlerA = Handler $ \l ccFX
                        -> unHandler handlerF (go l)
                         $ unHandler handlerA (,)
                         $ ccFX
    where go l a2b (a,x) = l (a2b a) x

-- 'runHandler' is also pretty much the same as before, except we need to start
-- at some 'f', so we pick 'Identity'.
runHandler :: Applicative m
           => Handler m n Identity f a -> n (f a)
runHandler handler = unHandler handler const
                   $ pure (Identity ())

-- In the simple case in which no branches are added to the 'f', we still have
-- 'Identity' at the end, so we unwrap it for convenience.
runSimpleHandler :: (Applicative m, Functor n)
                 => Handler m n Identity Identity a -> n a
runSimpleHandler = fmap runIdentity . runHandler


-- Oh, and it turns out mtl doesn't actually provide a typeclass called
-- 'MonadMaybe', so I had to write my own. There is nothing interesting here,
-- it's just the normal mtl boilerplate.

class Monad m => MonadMaybe m where
  nothing :: m a

data MaybeT m a = MaybeT { runMaybeT :: m (Maybe a) }

instance Monad m => MonadMaybe (MaybeT m) where
  nothing = MaybeT $ pure Nothing

-- Okay, maybe this bit is interesting if you haven't seen it before: it's a
-- way to use overlapping instances to eliminate the quadratic instances
-- problem by implementing the 'MonadMaybe' instance for all the other monad
-- transformers. Unfortunately, mtl doesn't use that trick, so I still have to
-- define an instance of 'MonadReader', 'MonadState', etc. for my new
-- transformer. Oh and btw, this trick doesn't work if your typeclass has
-- higher-order effects such as 'local'.
instance {-# OVERLAPPABLE #-}
         (MonadTrans t, Monad (t m), MonadMaybe m)
      => MonadMaybe (t m) where
  nothing = lift nothing

---------------------------
-- BEGIN MTL BOILERPLATE --
---------------------------

instance Functor m => Functor (MaybeT m) where
  fmap a2b = MaybeT . fmap (fmap a2b) . runMaybeT

instance Applicative m => Applicative (MaybeT m) where
  pure = MaybeT . pure . Just
  maybeF <*> maybeA = MaybeT $ (<*>)
                           <$> runMaybeT maybeF
                           <*> runMaybeT maybeA

instance Monad m => Monad (MaybeT m) where
  maybeA >>= f = MaybeT $ do
    r <- runMaybeT maybeA
    case r of
      Just a  -> runMaybeT (f a)
      Nothing -> pure Nothing

instance MonadTrans MaybeT where
  lift = MaybeT . fmap Just

instance MonadReader r m => MonadReader r (MaybeT m) where
  ask = lift ask
  local f = MaybeT . local f . runMaybeT

instance MonadWriter w m => MonadWriter w (MaybeT m) where
  tell = lift . tell
  listen = error "who uses 'listen' anyway"
  pass   = error "who uses 'pass' anyway"

instance MonadState s m => MonadState s (MaybeT m) where
  get = lift get
  put = lift . put

instance MonadError e m => MonadError e (MaybeT m) where
  throwError = lift . throwError
  catchError body handle = MaybeT $ catchError (runMaybeT body)
                                               (runMaybeT . handle)

-------------------------
-- END MTL BOILERPLATE --
-------------------------


main :: IO ()
main = doctest ["src/Main.hs"]