Church-encoded free and operational monad

free.hs

{-# LANGUAGE Rank2Types, TypeOperators, DeriveFunctor #-}

module Main where

import Control.Monad (join)

-- Church encoding of Free monad
newtype F f a = F { runF :: forall r. (a -> r) -> (f r -> r) -> r }

instance Functor (F f) where
    fmap f (F k) = F (\p -> k (p . f))

instance Monad (F f) where
    return a = F (\p _ -> p a)
    (F k) >>= f = F (\p r -> k (\a -> runF (f a) p r) r)

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

foldMap :: Monad g => f :~> g -> F f :~> g
foldMap f (F k) = k return (join . f)

lift :: Functor f => f a -> F f a
lift f = F (\p r -> r (fmap p f))

data Interact a = Ask String (String -> a)
                | Tell String a
                deriving Functor

ask :: String -> F Interact String
ask s = lift (Ask s id)

tell :: String -> F Interact ()
tell s = lift (Tell s ())

prg :: F Interact ()
prg = do
    first <- ask "First name: "
    last <- ask "Last name: "
    tell (unwords ["Hello,", first, last ++ "!"])

console :: Interact :~> IO
console (Ask prompt next) = putStr prompt >> fmap next getLine
console (Tell msg next) = putStrLn msg >> return next

main = return ()

op.hs

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

module Main where

-- Church encoding of Operational monad
newtype Op f a =
    Op { runOp :: forall r. (a -> r) -> (forall b. f b -> (b -> r) -> r) -> r }

instance Functor (Op f) where
    fmap f (Op k) = Op (\r -> k (r . f))

instance Monad (Op f) where
    return a = Op (\r _ -> r a)
    (Op k) >>= f = Op (\r b -> k (\a -> runOp (f a) r b) b)

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

foldMap :: Monad g => f :~> g -> Op f :~> g
foldMap f (Op k) = k return (\a next -> f a >>= next)

lift :: f a -> Op f a
lift f = Op (\r b -> b f r)

data Interact a where
    Ask :: String -> Interact String
    Tell :: String -> Interact ()

ask :: String -> Op Interact String
ask = lift . Ask

tell :: String -> Op Interact ()
tell = lift . Tell

prg :: Op Interact ()
prg = do
    first <- ask "First name: "
    last <- ask "Last name: "
    tell (unwords ["Hello,", first, last ++ "!"])

console :: Interact :~> IO
console (Ask prompt) = putStr prompt >> getLine
console (Tell msg) = putStrLn msg

main = return ()

Op.scala

sealed trait ~>[F[_], G[_]] {
  def apply[A](f: F[A]): G[A]
}

trait Monad[M[_]] {
  def pure[A](a: A): M[A]
  def flatMap[A, B](a: M[A])(f: A => M[B]): M[B]
}

object Monad {
  def apply[F[_]: Monad]: Monad[F] = implicitly[Monad[F]]
}

trait Bind[F[_], R] {
  def apply[B]: F[B] => (B => R) => R
}

trait Op[F[_], A] {
  def apply[R]: (A => R) => Bind[F, R] => R

  def flatMap[B](f: A => Op[F, B]): Op[F, B] =
    new Op[F,B] {
      def apply[R] = ret => bind =>
        Op.this.apply(a => f(a).apply(ret)(bind))(bind)
    }

  def map[B](f: A => B): Op[F, B] =
    flatMap(a => new Op[F,B] {
      def apply[R] = ret => _ => ret(f(a))
    })

  def foldMap[G[_]: Monad](f: F ~> G): G[A] =
    this.apply(a => Monad[G].pure(a))(new Bind[F, G[A]] {
      def apply[B] = fx => next => Monad[G].flatMap(f(fx))(next)
    })
}

object Op {
  def lift[F[_],A](f: F[A]): Op[F,A] =
    new Op[F,A] {
      def apply[R] = ret => bind => bind.apply(f)(ret)
    }
}

sealed trait Interact[A]
case class Ask(prompt: String) extends Interact[String]
case class Tell(msg: String) extends Interact[Unit]

object Interact {
  import Op._
  def ask(prompt: String): Op[Interact,String] = lift(Ask(prompt))
  def tell(msg: String): Op[Interact,Unit] = lift(Tell(msg))
}

object Id {
  type Id[A] = A
 
  implicit val identityMonad: Monad[Id] = new Monad[Id] {
    def pure[A](a: A) = a
    def flatMap[A,B](a: A)(f: A => B) = f(a)
  }
}

import Id._
 
object Console extends (Interact ~> Id) {
  def apply[A](i: Interact[A]) = i match {
    case Ask(prompt) =>
      println(prompt)
      readLine
    case Tell(msg) =>
      println(msg)
  }
}

object Main {
  def prg = {
    import Interact._

    for {
      first <- ask("first name: ")
      last  <- ask("last name: ")
      _ <- tell("hello, " + first + " " + last + "!")
    } yield ()
  }

  def main = prg.foldMap(Console)
}