Adjoint functors determine monad transformers

AdjointTrans.hs

-- see https://stackoverflow.com/q/49322276/2684007

{-# LANGUAGE DeriveFunctor         #-}
{-# LANGUAGE MultiParamTypeClasses #-}

import           Control.Monad
import           Data.Functor
import           Data.Functor.Adjunction

newtype Three g f m a = Three { getThree :: g (m (f a)) }
  deriving Functor

instance (Adjunction f g, Monad m) => Monad (Three g f m) where
  return  = Three . fmap return . unit
  m >>= f = Three $ fmap (>>= counit . fmap (getThree . f)) (getThree m)

instance (Adjunction f g, Monad m) => Applicative (Three g f m) where
  pure  = return
  (<*>) = ap

lift :: (Adjunction f g, Monad m) => m a -> Three g f m a
lift = Three . distributeR . fmap unit
       -- or
       -- Three . fmap sequenceL . unit

distributeR :: (Adjunction f g, Functor m) => m (g x) -> g (m x)
distributeR mgx = leftAdjunct (\fa -> fmap (counit . (fa $>)) mgx) ()

sequenceL :: (Adjunction f g, Functor m) => f (m a) -> m (f a)
sequenceL = (\(mx, fu) -> fmap (\x -> unsplitL x fu) mx) . splitL