Freer monad example

Freer.hs

{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
{-# OPTIONS_GHC -Wall #-}

module Freer
  ( Freer
  , liftFreer
  , foldFreer
  ) where

import Control.Applicative
import Control.Monad
import Control.Monad.Free.Church
import Data.Functor.Coyoneda

newtype Freer f a =
  Freer (forall m. MonadFree (Coyoneda f) m =>
                     m a)

instance Functor (Freer f) where
  {-# INLINE fmap #-}
  fmap = liftA

instance Applicative (Freer f) where
  {-# INLINE pure #-}
  pure a = Freer $ pure a
  {-# INLINE (<*>) #-}
  (<*>) = ap

instance Monad (Freer f) where
  {-# INLINE return #-}
  return = pure
  {-# INLINE (>>=) #-}
  Freer m >>= f =
    Freer $
    m >>= \a ->
      let Freer r = f a
       in r

{-# INLINE liftFreer #-}
liftFreer :: f a -> Freer f a
liftFreer f = Freer $ liftF $ liftCoyoneda f

{-# INLINE foldFreer #-}
foldFreer :: Monad g => (forall x. f x -> g x) -> Freer f a -> g a
foldFreer f (Freer m) = foldF (lowerCoyoneda . hoistCoyoneda f) m

FreerState.hs

{-# LANGUAGE GADTs #-}
{-# OPTIONS_GHC -Wall #-}

module FreerState where

import qualified Control.Monad.Reader as MTL
import qualified Control.Monad.State.Strict as MTL
import Control.Monad.Trans
import Data.IORef
import Freer

data State s a where
  Get :: State s s
  Put :: s -> State s ()

type StateM s = Freer (State s)

get :: StateM s s
get = liftFreer Get

put :: s -> StateM s ()
put = liftFreer . Put

runStatePure :: StateM s a -> s -> (a, s)
runStatePure = MTL.runState . foldFreer f
  where
    f :: State s a -> MTL.State s a
    f Get = MTL.get
    f (Put s) = MTL.put s

runStateIO :: StateM s a -> IORef s -> IO a
runStateIO = MTL.runReaderT . foldFreer f
  where
    f :: State s a -> MTL.ReaderT (IORef s) IO a
    f Get = MTL.ask >>= lift . readIORef
    f (Put s) = MTL.ask >>= \ref -> lift (writeIORef ref s)