Extensible Effects with Freer Monad.hs

{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}

module Main where

class Monad m => Handler (g :: * -> *) (m :: * -> *) where
    handle :: g a -> (a -> m b) -> m b
    
data Freer :: (* -> *) -> * -> * where
    Pure :: a -> Freer f a
    Bound :: f a -> (a -> Freer f b) -> Freer f b -- not handle f a, but store it
    
-- ｜ constructor for Freer
etaF :: g a -> Freer g a
etaF fa = Bound fa Pure

instance Functor (Freer g) where
    fmap f x = pure f <*> x

instance Applicative (Freer g) where
    pure = Pure
    (Pure f) <*> x = fmap f x
    (Bound u q) <*> x = Bound u $ \f' -> (q f') <*> x

instance Monad (Freer g) where
    (Pure x) >>= k = k x
    (Bound u q) >>= k = Bound u $ \x -> (q x) >>= k
    
-- | general handle function
eff :: (Monad m, Handler g m) => Freer g a -> (a -> m b) -> m b
eff (Pure x) k = k x
eff (Bound e q) k = handle e $ \x' -> eff (q x') k

---

data Interaction :: * -> * where
    Say :: String -> Interaction ()
    Ask :: Interaction String

instance Handler Interaction IO where
    handle (Say s) k = putStrLn s >>= k
    handle Ask k = getLine >>= k
    
say :: String -> Freer Interaction ()
say s = etaF $ Say s

ask :: Freer Interaction String
ask = etaF $ Ask

run :: (Monad m, Handler g m) => Freer g a -> m a
run x = eff x pure
    
main :: IO ()
main = run $ do
    say "hello"
    x <- ask
    say ("got " ++ x)
    say "Finish"