TransformerStacks.hs

{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}


import Control.Monad
import Data.Constraint


class MonadTrans t where
    transform :: Monad m :- Monad (t m)
    lift :: Monad m => m a -> t m a


-- Monad transformer composition

newtype (t :.: u) m a = C { unC :: t (u m) a }

instance (MonadTrans t, MonadTrans u, Monad f) => Functor ((t :.: u) f) where
    fmap = liftM

instance (MonadTrans t, MonadTrans u, Monad f) => Applicative ((t :.: u) f) where
    pure = return
    (<*>) = ap

instance (MonadTrans t, MonadTrans u, Monad m) => Monad ((t :.: u) m) where
    return = lift . return
    (>>=) :: forall a b. (t :.: u) m a -> (a -> (t :.: u) m b) -> (t :.: u) m b
    C tuma >>= f = C (tuma >>= (unC . f)) \\ umtum \\ mum  -- what curious variable names!
        where mum = transform :: Monad m :- Monad (u m)
              umtum = transform :: Monad (u m) :- Monad (t (u m))

instance (MonadTrans t, MonadTrans u) => MonadTrans (t :.: u) where
    transform = Sub Dict
    lift :: forall m a. Monad m => m a -> (t :.: u) m a
    lift = C . lift . lift \\ umtum \\ mum
        where mum = transform :: Monad m :- Monad (u m)
              umtum = transform :: Monad (u m) :- Monad (t (u m))