HComonad

haasn 2013-10-03 06:58:07.654111 UTC

1{-# LANGUAGE RankNTypes, TypeOperators, ImplicitParams, DefaultSignatures #-}
2
3import Control.Monad
4import Control.Comonad
5
6data Free f a = Return a | Nest (f (Free f a))
7
8type f :-> g = forall a. f a -> g a
9
10instance Functor f => Functor (Free f) where
11 fmap f (Return a) = Return (f a)
12 fmap f (Nest m) = Nest (fmap (fmap f) m)
13
14instance Functor f => Monad (Free f) where
15 return = Return
16 Return x >>= f = f x
17 Nest m >>= f = Nest (fmap (>>= f) m)
18
19class HFunctor f where
20 -- should also imply Functor (f a) for any Functor a
21 -- because these are functors over functor categories, not just slice ones
22 hmap :: (Functor a, Functor b) => (a :-> b) -> f a :-> f b
23
24class HFunctor m => HMonad m where
25 hret :: Functor f => f :-> m f
26 hbind :: (Functor f, Functor g) => (f :-> m g) -> m f :-> m g
27 default hbind :: Functor (m g) => (Functor f, Functor g) => (f :-> m g) -> m f :-> m g
28 hbind f m = hjoin (hmap f m)
29 hjoin :: (Functor f) => m (m f) :-> m f
30
31instance HFunctor Free where
32 hmap f (Return x) = Return x
33 hmap f (Nest m) = Nest (fmap (hmap f) (f m))
34
35instance HMonad Free where
36 hret x = Nest (fmap Return x)
37 hjoin (Return x) = Return x
38 hjoin (Nest m) = join (fmap hjoin m)
39
40data Cofree f a = a :< f (Cofree f a)
41
42instance Functor f => Functor (Cofree f) where
43 fmap f (a :< as) = f a :< fmap (fmap f) as
44
45instance Functor f => Comonad (Cofree f) where
46 extract (a :< _) = a
47 extend f x@(_ :< xs) = f x :< fmap (extend f) xs
48 duplicate x@(_ :< xs) = x :< fmap duplicate xs
49
50class HFunctor w => HComonad w where
51 hextract :: Functor f => w f :-> f
52 hduplicate :: Functor f => w f :-> w (w f)
53 hextend :: (Functor f, Functor g) => (w f :-> g) -> w f :-> w g
54 default hextend :: (Functor (w f), Functor f, Functor g) => (w f :-> g) -> w f :-> w g
55 hextend f = hmap f . hduplicate
56
57instance HFunctor Cofree where
58 hmap f (a :< as) = a :< fmap (hmap f) (f as)
59
60instance HComonad Cofree where
61 hextract (a :< as) = fmap extract as
62 hduplicate x@(a :< as) = a :< (hduplicate x :< fmap (fmap hduplicate . duplicate) as)