Homomorphisms.hs

{-# Language GADTs #-}

module Homomorphisms where

import Control.Monad
import Control.Applicative

import Data.Monoid hiding (Endo)
import qualified Control.Category as C

-------------------------------------------------------------------------------
-- Morphisms
-------------------------------------------------------------------------------

data Homomorphism a b where
  Hom :: (a -> b) -> Homomorphism a b

data Endomorphism a b where
  Endo :: (a -> a) -> Endomorphism a a

data Isomorphism a b = Iso { to :: a -> b, from :: b -> a }

data KleisliArrow m a b where
  K :: Monad m => (a -> m b) -> KleisliArrow m a b

apK :: Monad m => (KleisliArrow m a b) -> a -> m b
apK (K f) a = f a

apEndo :: Endomorphism a a -> a -> a
apEndo (Endo f) a = f a

apHom :: Homomorphism a b -> a -> b
apHom (Hom f) a = f a

-------------------------------------------------------------------------------
-- Functor Instances
-------------------------------------------------------------------------------

instance Functor (Homomorphism t) where
  fmap f (Hom a) = Hom (f . a)

instance Applicative (Homomorphism t) where
  pure a = Hom $ const a
  (Hom f) <*> (Hom g) = Hom $ \a -> f a $ g a

-------------------------------------------------------------------------------
-- Monad Instances
-------------------------------------------------------------------------------

instance Monad (Homomorphism t) where
  (Hom f) >>= g = Hom $ \a -> apHom (g $ f a) a
  return a = Hom $ const a

instance Monad m => C.Category (KleisliArrow m) where
  id = K (return . id)
  (K f) . (K g) = K $ g >=> f

-------------------------------------------------------------------------------
-- Category Instances
-------------------------------------------------------------------------------

instance C.Category Homomorphism where
  id = Hom id
  (Hom f) . (Hom g) = Hom (f . g)

instance C.Category Endomorphism where
  id = Endo id
  (Endo f) . (Endo g) = Endo (f . g)

instance C.Category Isomorphism where
  id = Iso id id
  (Iso f f') . (Iso g g') = Iso (f . g) (g' . f')

-------------------------------------------------------------------------------
-- Monoid Instances
-------------------------------------------------------------------------------

instance (a ~ b) => Monoid (Endomorphism a b) where
  mempty = Endo id
  mappend (Endo f) (Endo g) = Endo $ g . f

instance (Monad m, a ~ b) => Monoid (KleisliArrow m a b) where
  mempty = K return
  mappend f g = K $ apK g >=> apK f