module Control.Functor.KanExtension
(
Ran(..)
, toRan, fromRan
, liftRan, lowerRan
, adjointToRan, ranToAdjoint
, ranToComposedAdjoint, composedAdjointToRan
, composeRan, decomposeRan
, Lan(..)
, toLan, fromLan
, liftLan, lowerLan
, adjointToLan, lanToAdjoint
, composeLan, decomposeLan
, lanToComposedAdjoint, composedAdjointToLan
, improveFree
, worsenCofree
) where
import Prelude hiding (abs)
import Control.Comonad.Context
import Control.Comonad.Cofree
import Control.Functor.Composition
import Control.Functor.Extras
import Control.Functor.Pointed ()
import Control.Functor.HigherOrder
import Control.Functor.Adjunction
import Control.Monad.State
import Control.Monad.Reader
import Control.Monad.Identity
import Control.Monad.Free
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))
composeRan :: Composition o => Ran f (Ran g h) :~> Ran (f `o` g) h
composeRan r = Ran (\f -> runRan (runRan r (decompose . f)) id)
decomposeRan :: (Functor f, Composition o) => Ran (f `o` g) h :~> Ran f (Ran g h)
decomposeRan r = Ran (\f -> Ran (\g -> runRan r (compose . fmap g . f)))
liftRan :: Monad m => m a -> Ran m m a
liftRan m = Ran (m >>=)
lowerRan :: Monad m => Ran m m a -> m a
lowerRan a = runRan a return
instance MonadReader r m => MonadReader r (Ran m m) where
ask = liftRan ask
local f m = Ran (\c -> ask >>= \r -> local f (runRan m (local (const r) . c)))
instance MonadIO m => MonadIO (Ran m m) where
liftIO = liftRan . liftIO
instance MonadState s m => MonadState s (Ran m m) where
get = liftRan get
put = liftRan . put
instance MonadFree f m => MonadFree f (Ran m m) where
inFree t = Ran (inFree . flip fmap t . flip runRan)
adjointToRan :: Adjunction f g => f :~> Ran g Identity
adjointToRan f = Ran (\a -> Identity $ rightAdjunct a f)
ranToAdjoint :: Adjunction f g => Ran g Identity :~> f
ranToAdjoint r = runIdentity (runRan r unit)
ranToComposedAdjoint :: (Composition o, Adjunction f g) => Ran g h :~> (h `o` f)
ranToComposedAdjoint r = compose (runRan r unit)
composedAdjointToRan :: (Functor h, Composition o, Adjunction f g) => (h `o` f) :~> Ran g h
composedAdjointToRan f = Ran (\a -> fmap (rightAdjunct a) (decompose f))
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
liftLan :: Comonad w => w a -> Lan w w a
liftLan = Lan extract
lowerLan :: Comonad w => Lan w w a -> w a
lowerLan (Lan f c) = extend f c
adjointToLan :: Adjunction f g => g :~> Lan f Identity
adjointToLan = Lan counit . Identity
lanToAdjoint :: Adjunction f g => Lan f Identity :~> g
lanToAdjoint (Lan f v) = leftAdjunct f (runIdentity v)
lanToComposedAdjoint :: (Functor h, Composition o, Adjunction f g) => Lan f h :~> (h `o` g)
lanToComposedAdjoint (Lan f v) = compose (fmap (leftAdjunct f) v)
composedAdjointToLan :: (Composition o, Adjunction f g) => (h `o` g) :~> Lan f h
composedAdjointToLan = Lan counit . decompose
instance ComonadContext e m => ComonadContext e (Lan m m) where
getC = getC . lowerLan
modifyC f = modifyC f . lowerLan
instance ComonadCofree f w => ComonadCofree f (Lan w w) where
outCofree (Lan f c) = fmap (Lan f) (outCofree c)
composeLan :: (Functor f, Composition o) => Lan f (Lan g h) :~> Lan (f `o` g) h
composeLan (Lan f (Lan g h)) = Lan (f . fmap g . decompose) h
decomposeLan :: Composition o => Lan (f `o` g) h :~> Lan f (Lan g h)
decomposeLan (Lan f h) = Lan (f . compose) (Lan id h)
improveFree :: Functor f => (forall m. MonadFree f m => m a) -> Free f a
improveFree m = lowerRan m
worsenCofree :: Functor f => (forall w. ComonadCofree f w => w a) -> Cofree f a
worsenCofree m = lowerLan m