FreerCofreer.hs

{-# LANGUAGE GADTs, DeriveFunctor, RankNTypes #-}

import Prelude hiding (Monad (..))

main = print ()

-----------------------------------------------------------------------

class Functor m => Monad m where
    return :: a                 -> m a
    join   :: m (m a)           -> m a
    bind   :: m x -> (x -> m a) -> m a
    join mma  = bind mma id
    bind mx f = join (fmap f mx)

liftM :: Monad m => (a -> b) -> m a -> m b
liftM f ma = bind ma (return . f)

(>=>) :: Monad m => (a -> m b) -> (b -> m c) -> (a -> m c)
(f >=> g) a = bind (f a) g

-----------------------------------------------------------------------

class Functor w => Comonad w where
    extract   :: w a -> a
    duplicate :: w a -> w (w a)
    extend    :: w a -> (w a -> x) -> w x
    duplicate wa   = extend wa id
    extend    wa f = fmap f (duplicate wa)

liftW :: Comonad w => (a -> b) -> w a -> w b
liftW f wa = extend wa (f . extract)

(=>=) :: Comonad w => (w a -> b) -> (w b -> c) -> (w a -> c)
(f =>= g) wa = g (extend wa f)

-----------------------------------------------------------------------

data Free m a where
    Return :: a            -> Free m a
    Join   :: m (Free m a) -> Free m a
    deriving Functor

instance Functor m => Monad (Free m) where
    return   = Return
    join ffa = case ffa of
        Return fa   -> fa
        Join   mffa -> Join (fmap join mffa)

runFree :: Monad m => Free m a -> m a
runFree fa = case fa of
    Return a   -> return a
    Join   mfa -> join (fmap runFree mfa)

-----------------------------------------------------------------------

data Cofree w a = Cofree {
    _extract   :: a,
    _duplicate :: w (Cofree w a)
} deriving Functor

instance Functor w => Comonad (Cofree w) where
    extract      = _extract
    duplicate ca = Cofree {
        _extract   = ca,
        _duplicate = fmap duplicate (_duplicate ca)
    }

runCofree :: Comonad w => w a -> Cofree w a
runCofree wa = Cofree {
    _extract   = extract wa,
    _duplicate = fmap runCofree (duplicate wa)
}

-----------------------------------------------------------------------

data Freer m a where
    Return' :: a -> Freer m a
    Bind    :: m x -> (x -> Freer m a) -> Freer m a

instance Functor (Freer m) where
    fmap = liftM

instance Monad (Freer m) where
    return    = Return'
    bind mx f = case mx of
        Return'  a  -> f a
        Bind mx' f' -> Bind mx' (f' >=> f)

runFreer :: Monad m => Freer m a -> m a
runFreer fa = case fa of
    Return' a -> return a
    Bind mx f -> bind mx (runFreer . f)

-----------------------------------------------------------------------

data Cofreer w a = Cofreer {
    _extract' :: a,
    _extend   :: forall x. (Cofreer w a -> x) -> w x
}

instance Functor (Cofreer w) where
    fmap = liftW

instance Comonad (Cofreer w) where
    extract     = _extract'
    extend wa f = Cofreer {
        _extract' = f wa,
        _extend   = \f' -> _extend wa (f =>= f')
    }

runCofreer :: Comonad w => w a -> Cofreer w a
runCofreer wa = Cofreer {
    _extract' = extract wa,
    _extend   = \f -> extend wa (f . runCofreer)
}