Adjunction.hs

-----------------------------------------------------------------------------
-- |
-- Module      :  Control.Functor.Adjunction
-- Copyright   :  2004 Dave Menendez
-- License     :  BSD3
-- 
-- Maintainer  :  dan.doel@gmail.com
-- Stability   :  experimental
-- Portability :  non-portable (fundeps)
--
-----------------------------------------------------------------------------

module Control.Functor.Adjunction where

import Control.Functor
import Control.Comonad

{-|
Minimal definitions:

1. @leftAdjunct@ and @rightAdjunct@

2. @unit@ and @counit@

Given functors @f@ and @g@, @Adjunction f g@ implies @Monad (g `'O'` f)@ and
@'Comonad' (f `'O'` g)@.

-}
class (Functor f, Functor g) => Adjunction f g | f -> g, g -> f where
    leftAdjunct  :: (f a -> b) -> a -> g b
    rightAdjunct :: (a -> g b) -> f a -> b

    unit   :: a -> g (f a)
    counit :: f (g a) -> a

    unit           = leftAdjunct id
    counit         = rightAdjunct id
    leftAdjunct f  = fmap f . unit
    rightAdjunct g = counit . fmap g

instance (Adjunction f g) => Monad (O g f) where
  return  = Comp . unit
  m >>= k = Comp . fmap (rightAdjunct (deComp . k)) . deComp $ m

instance (Adjunction f g) => Comonad (O f g) where
  extract  = counit . deComp
  extend f = Comp . fmap (leftAdjunct (f . Comp)) . deComp
  
instance Adjunction ((,) a) ((->) a) where
  unit t = \x -> (x,t)
  counit (x,f) = f x