KanExtension.hs

-----------------------------------------------------------------------------
-- |
-- Module      :  Control.Functor.KanExtension
-- Copyright   :  (C) 2008 Edward Kmett
-- License     :  BSD-style (see the file LICENSE)
--
-- Maintainer  :  Edward Kmett <ekmett@gmail.com>
-- Stability   :  experimental
-- Portability :  non-portable (rank-2 polymorphism)
--
-- Left and right Kan extensions, expressed as higher order functors
--
-- Included is the 'monad generated by a functor' @Ran f f@
-- and the comonad cogenerated by a functor @Lan f f@.
----------------------------------------------------------------------------
module Control.Functor.KanExtension 
	( Ran(..)
	, toRan, fromRan
	, Lan(..)
	, toLan, fromLan
	, rep, abs
	, corep, coabs
	) where

import Prelude hiding (abs)
import Control.Functor.Composition
import Control.Functor.Extras
import Control.Functor.Pointed ()
import Control.Functor.HigherOrder
import Control.Comonad
import Control.Monad.Cont

-- | Right Kan Extension
newtype Ran g h a = Ran { runRan :: forall b. (a -> g b) -> h b }

toRan :: (Composition o, Functor k) => (k `o` g :~> h) -> k :~> Ran g h
toRan s t = Ran (s . compose . flip fmap t)

fromRan :: Composition o => (k :~> Ran g h) -> (k `o` g) :~> h
fromRan s = flip runRan id . s . decompose

instance HFunctor (Ran g) where
	hfmap f (Ran m) = Ran (f . m)
	ffmap f m = Ran (\k -> runRan m (k . f))

instance Functor (Ran g h) where
	fmap f m = Ran (\k -> runRan m (k . f))

instance Pointed (Ran f f) where
	point x = Ran (\k -> k x)

instance Monad (Ran f f) where
	return = point
	m >>= k = Ran (\c -> runRan m (\a -> runRan (k a) c))

-- | See <http://wwwtcs.inf.tu-dresden.de/%7Evoigt/mpc08.pdf>
rep :: Monad m => m a -> Ran m m a
rep m = Ran (m >>=)

abs :: Monad m => Ran m m a -> m a 
abs a = runRan a return

-- | Left Kan Extension
data Lan g h a = forall b. Lan (g b -> a) (h b)

toLan :: (Composition o, Functor f) => (h :~> (f `o` g)) -> Lan g h :~> f
toLan s (Lan f v) = fmap f . decompose $ s v

fromLan :: Composition o => (Lan g h :~> f) -> h :~> (f `o` g)
fromLan s = compose . s . Lan id

instance Functor g => HFunctor (Lan g) where
	ffmap f (Lan g h) = Lan (f . g) h
	hfmap f (Lan g h) = Lan g (f h)

instance Functor (Lan f g) where
	fmap f (Lan g h) = Lan (f . g) h

instance Copointed (Lan f f) where
	extract (Lan f a) = f a

instance Comonad (Lan f f) where
	duplicate (Lan f ws) = Lan (Lan f) ws

coabs :: Comonad w => w a -> Lan w w a
coabs = Lan extract 

corep :: Comonad w => Lan w w a -> w a 
corep (Lan f c) = extend f c