Free Monad & Cofree Comonad

Main.hs

{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE LambdaCase            #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies          #-}
{-# LANGUAGE TypeOperators         #-}
{-# LANGUAGE TypeSynonymInstances  #-}


module Main where

import           Control.Comonad.Cofree     (Cofree (..))
import           Control.Comonad.Env        (Env, EnvT (..), env)
import           Control.Monad.Free         (Free (..), liftF)
import           Control.Monad.Trans.Reader (Reader, ReaderT (..), reader)
import           Data.Functor.Compose       (Compose (..))
import           Data.Functor.Identity      (Identity (..))
import           GHC.Generics

-- library code

type family Dual f where
  Dual (Free f) = Cofree (Dual f)
  Dual (Cofree f) = Free (Dual f)
  Dual (f `Compose` g) = (Dual f) `Compose` (Dual g)
  Dual (f :+: g) = (Dual f) :*: (Dual g)
  Dual (f :*: g) = (Dual f) :+: (Dual g)
  Dual (Reader e) = Env e
  Dual (Env e) = Reader e
  Dual (Identity) = Identity

class Zap f g where
  zap :: (a -> b -> c) -> f a -> g b -> c

flipZap :: Zap f g => (a -> b -> c) -> g a -> f b -> c
flipZap = flip . zap . flip

instance Zap Identity Identity where
  zap f (Identity x) (Identity y) = f x y

instance Zap (Reader e) (Env e) where
  zap f (ReaderT r) (EnvT e (Identity y)) =
    f (runIdentity $ r e) y

instance Zap (Env e) (Reader e) where
  zap = flipZap

instance (Zap f f', Zap g g') =>
  Zap (f :+: g) (f' :*: g') where
    zap f (L1 x) (y :*: _) = zap f x y
    zap f (R1 x) (_ :*: y) = zap f x y

instance (Zap f' f, Zap g' g) =>
  Zap (f :*: g) (f' :+: g') where
    zap = flipZap

instance (Zap f f', Zap g g') =>
  Zap (f `Compose` g) (f' `Compose` g') where
    zap f (Compose fg) (Compose f'g') = zap (zap f) fg f'g'

instance Zap f g => Zap (Free f) (Cofree g) where
  zap f (Pure x) (y :< _) = f x y
  zap f (Free a) (_ :< b) = zap (zap f) a b

-- application code

-- essentially: ClientF a = SendC Bool a | ReceiveC (Int -> a)
type Client = Free (Env Bool :+: Reader Int)
-- dual to ClientF is ServerF a = Server { receiveS :: Bool -> a, sendS :: (Int, a) }
type Server = Dual Client

receiveC :: Client Int
receiveC = liftF $ R1 $ ReaderT Identity

sendC :: Bool -> Client ()
sendC b = liftF $ L1 $ env b ()


-- the client sends some Bool values to the server and receives an Int
client :: Client String
client = do
  sendC False
  sendC False
  sendC True
  sendC False
  sendC True
  count <- receiveC
  return $
    "Sent 'True' " <> show count <> " times"
    
-- the server accepts the Bool values and accumulates the amount of True's sent
-- then sends that amount when an Int is requested
server :: Int -> Server Int
server x = x :< (receiveS :*: sendS)
  where
    receiveS =
      reader $ \case
                  True -> server $ x + 1
                  False -> server x
    sendS = env x (server x)

main :: IO ()
main = print $ zap (,) client (server 0)
-- ("Sent 'True' 2 times",2)