EitherT from coslice categories

EitherT.hs

-- Ever wondered where monad transformers come from?

{-# LANGUAGE TypeOperators #-}

import Control.Arrow ((+++))
import Control.Monad ((<=<))
import Control.Monad.Identity (Identity)


-- Coslice category

  -- Read Coslice e x as the type of evidence that x is
  -- the underlying object of some object of e/Hask.

type Coslice e x = e -> x


-- Free/forgetful adjunction

type F e x = Either e x

fMap :: (x -> y) -> (F e x -> F e y)
fMap f = id +++ f

free :: Coslice (F e x)
free = Left


type U e x = x

uMap :: (x -> y) -> (U e x -> U e y)
uMap f = f


transposeL :: (F e x -> y) -> (x -> U e y)
transposeL f = f . Right

transposeR :: Coslice e y -> (x -> U e y) -> (F e x -> y)
transposeR c f = either c f


-- Monad (via its Kleisli category)

type T e x = U e (F e x)

data E -- fix e = E for notational convenience

type x +> y = x -> T E y

idT :: x +> x
idT = transposeL id

compT :: (y +> z) -> (x +> y) -> (x +> z)
compT f g = transposeL (transposeR' f . transposeR' g)
 where
  transposeR' :: (x -> U e (F e y)) -> (F e x -> F e y)
  transposeR' = transposeR free


-- Monad transformer (similarly)

type Tr e m x = U e (m (F e x))

type M = Identity -- fix m = M for notational convenience

type x ++> y = x -> Tr E M y

idTr :: x ++> x
idTr = transposeL return

compTr :: (y ++> z) -> (x ++> y) -> (x ++> z)
compTr f g = transposeL (transposeR' f <=< transposeR' g)
 where
  transposeR' :: Monad m => (x -> U e (m (F e y))) -> (F e x -> m (F e y))
  transposeR' = transposeR (return . free)