HComonad

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
{-# LANGUAGE RankNTypes, TypeOperators, ImplicitParams, DefaultSignatures #-}

import Control.Monad
import Control.Comonad

data Free f a = Return a | Nest (f (Free f a))

type f :-> g = forall a. f a -> g a

instance Functor f => Functor (Free f) where
  fmap f (Return a) = Return (f a)
  fmap f (Nest m) = Nest (fmap (fmap f) m)

instance Functor f => Monad (Free f) where
  return = Return
  Return x >>= f = f x
  Nest m >>= f = Nest (fmap (>>= f) m)

class HFunctor f where
  -- should also imply Functor (f a) for any Functor a 
  -- because these are functors over functor categories, not just slice ones
  hmap :: (Functor a, Functor b) => (a :-> b) -> f a :-> f b

class HFunctor m => HMonad m where
  hret :: Functor f => f :-> m f
  hbind :: (Functor f, Functor g) => (f :-> m g) -> m f :-> m g
  default hbind :: Functor (m g) => (Functor f, Functor g) => (f :-> m g) -> m f :-> m g
  hbind f m = hjoin (hmap f m)
  hjoin :: (Functor f) => m (m f) :-> m f

instance HFunctor Free where
  hmap f (Return x) = Return x
  hmap f (Nest m) = Nest (fmap (hmap f) (f m))

instance HMonad Free where
  hret x = Nest (fmap Return x)
  hjoin (Return x) = Return x
  hjoin (Nest m) = join (fmap hjoin m)

data Cofree f a = a :< f (Cofree f a)

instance Functor f => Functor (Cofree f) where
  fmap f (a :< as) = f a :< fmap (fmap f) as

instance Functor f => Comonad (Cofree f) where
  extract (a :< _) = a
  extend f x@(_ :< xs) = f x :< fmap (extend f) xs
  duplicate x@(_ :< xs) = x :< fmap duplicate xs

class HFunctor w => HComonad w where
  hextract :: Functor f => w f :-> f
  hduplicate :: Functor f => w f :-> w (w f)
  hextend :: (Functor f, Functor g) => (w f :-> g) -> w f :-> w g
  default hextend :: (Functor (w f), Functor f, Functor g) => (w f :-> g) -> w f :-> w g
  hextend f = hmap f . hduplicate

instance HFunctor Cofree where
  hmap f (a :< as) = a :< fmap (hmap f) (f as)

instance HComonad Cofree where
  hextract (a :< as) = fmap extract as
  hduplicate x@(a :< as) = a :< (hduplicate x :< fmap (fmap hduplicate . duplicate) as)