https://cs.ioc.ee/~tarmo/papers/uustalu-agp01.pdf

comonad.hs

—- Functors
{—
class Functor f where
fmap :: (a->b) ->fa-->fb
—}
-- Monads, comonads
class (Functor m) => Mon m where
unit :: a->ma
mult :: m (ma) -> ma
class (Functor n) => Comon n where
counit :: n a-> a
comult :: n a -> n (n a)
—— Bifunctors
class BiFunctor f where
bifmap :: (a —> b) —> (a’ —> b’) —> f a a’ —> f b b’
-- Bimonads, bicomonads
class (BiFunctor m) => BiMon m where
biunit a -> m a a’
bimult :: m Cm a a’) a’ -> m a a’
class (BiFunctor n) => BiComon n where
bicounit :: n a a’ -> a
bicomult :: n a a’ -> n (n a a’) a
—- Pointwise mu, nu type constructors
data Mu f a = In (f a (Mu f a))
unln :: Mu f a -> f a (Mu f a)
unln (In x) = x
cata :: (BiFunctor f) => Cf a c —> c) —> Mu f a —> c
cata phi = phi . bifmap id (cata phi) . unln
para :: CBiFunctor f) => Cf a Cc, Mu f a) —> c) —> Mu f a —> c
para phi = phi bifmap id (both (para phi) id) . unln
both :: Cc —> a) —> Cc —> a’) —> c —> (a, a’)
both g g’ x = (g x, g’ x)
data Nu f a = UnOut (f a (Nu f a))
out :: Nu f a -> f a (Nu f a)
out (UnOut x) = x
ana :: (BiFunctor f) => (c —> f a c) —> c —> Nu f a
ana phi = UnOut . bifmap id (ana phi) phi
apo :: (BiFunctor f) => Cc —> f a (Either c (Nu f a))) —> c —> Nu f a
apo phi = UnOut bifmap id (either (apo phi) id) . phi
either :: (a —> c) —> (a’ —> c) —> Either a a’ —> c
either g g’ (Left x) = g x
either g g’ (Right x) = g’ x
—}
-- Pointwise mu, nu functors
instance (BiFunctor f) => Functor (Mu f) where
fmap g = cata (In bifmap g id)
instance (BiFunctor f) > Functor (Nu f) where
fmap g = ana (bifmap g id out)
--Pointwise mu, nu monads
instance (BiMon m) => Mon (Mu m) where
unit = In . biunit
mult = cata (In bimult . bifmap unln id)
instance (BiMon m) => Mon (Nu m) where
unit = UnOut biimit
mult = apo (bimult bifmap (bifmap id Right) Left . bifmap out id . out)
-- Pointwise mu, nu comonads
instance (BiComon n) => Comon (Mu n) where
counit = bicounit . unln
comult = para (In bifmap In id bifmap (bifmap id snd) fst bicomult)
instance (BiComon n) => Comon (Nu n) where
counit = bicounit . out
comult = ana (bifmap UnOut id bicomult . out)