Applications as Coproducts of Free ADTs. http://www.47deg.com/blog/fp-for-the-average-joe-part3-free-monads

FreeComposition.hs

{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverlappingInstances #-}

module Main where

import Control.Monad.Free
import Control.Monad.State

-- Given separate data types representing operations

data Interaction k
  = Ask (String -> k)
  | Tell String k
  deriving Functor

data Persistence k
  = AddCat String k
  | GetAllCats ([String] -> k)
  deriving Functor

type Storage a = StateT [String] IO a

-- And the Inject type class described in Data Types a la carte per W. Swierstra's
-- http://www.cs.ru.nl/~W.Swierstra/Publications/DataTypesALaCarte.pdf

data Coproduct f g a = InL (f a) | InR (g a)

instance (Functor f, Functor g) => Functor (Coproduct f g) where
  fmap f (InL x) = InL (fmap f x)
  fmap f (InR x) = InR (fmap f x)

type f :+: g = Coproduct f g

class (Functor sub, Functor sup) => sub :<: sup where
  inj :: sub a -> sup a

instance Functor f => f :<: f where
  inj = id

instance (Functor f, Functor g) => f :<: (f :+: g) where
  inj = InL

instance (Functor f, Functor g, Functor h, f :<: g) => f :<: (h :+: g) where
  inj = InR . inj

-- We can create smart constructors that lift our data types
-- to the context of Free monads where `f` is in a Coproduct

tell :: (MonadFree f m, Interaction :<: f) => String -> m ()
tell s = liftF . inj $ Tell s ()

ask :: (MonadFree f m, Interaction :<: f) => m String
ask = liftF . inj $ Ask id

addCat :: (MonadFree f m, Persistence :<: f) => String -> m ()
addCat s = liftF . inj $ AddCat s ()

getAllCats :: (MonadFree f m, Persistence :<: f) => m [String]
getAllCats = liftF . inj $ GetAllCats id

-- Interpreters can be defined for each Algebra independently

class Functor f => Interpreter f where
  run :: f (Storage a) -> Storage a

instance Interpreter Interaction where
  run (Ask f) = (liftIO $ getLine) >>= f
  run (Tell a f) = (liftIO $ putStrLn a) >> f

instance Interpreter Persistence where
  run (AddCat a f) = (do
         xs <- get
         put (xs ++ [a])
         liftIO $ putStrLn ("Added : " ++ a)
         return ()) >> f
  run (GetAllCats f) = get >>= f

-- And combined for the Coproduct of those algebras

instance (Interpreter f, Interpreter g) => Interpreter (f :+: g) where
  run (InL x) = run x
  run (InR y) = run y

runFree :: Interpreter f => Free f a -> Storage a
runFree = iterM run

-- Any arbitrary program combining different datatypes
-- can be encoded by using the smart constructors in a monadic
-- fashion

program :: Free (Interaction :+: Persistence) ()
program = forever $ do
   tell "What's the cat's name?"
   name <- ask
   addCat name
   cats <- getAllCats
   tell (show cats ++ "\n")
   return ()


--- Separating program definition from interpretation

main :: IO ()
-- main = runFree program
main = runStateT (runFree program) [] >> return ()

FreeComposition.scala

import cats._
import cats.data._
import cats.free._
import cats.implicits._
import monix.eval.Task
import simulacrum.typeclass
import monix.cats._

import scala.util.Try

/** An application as a Coproduct of it's ADTs */
type Application[A] = Coproduct[Interact, DataOp, A]

/** User Interaction Algebra */
sealed trait Interact[A]
case class Ask(prompt: String) extends Interact[String]
case class Tell(msg: String) extends Interact[Unit]

/** Data Operations Algebra */
sealed trait DataOp[A]
case class AddCat(a: String) extends DataOp[String]
case class GetAllCats() extends DataOp[List[String]]

/** Smart Constructors */
class Interacts[F[_]](implicit I: Inject[Interact, F]) {
  def tell(msg: String): Free[F, Unit] = Free.inject[Interact, F](Tell(msg))
  def ask(prompt: String): Free[F, String] = Free.inject[Interact, F](Ask(prompt))
}

object Interacts {
  implicit def interacts[F[_]](implicit I: Inject[Interact, F]): Interacts[F] = new Interacts[F]
}

class DataOps[F[_]](implicit I: Inject[DataOp, F]) {
  def addCat(a: String): Free[F, String] = Free.inject[DataOp, F](AddCat(a))
  def getAllCats: Free[F, List[String]] = Free.inject[DataOp, F](GetAllCats())
}

object DataOps {
  implicit def dataOps[F[_]](implicit I: Inject[DataOp, F]): DataOps[F] = new DataOps[F]
}

def program(implicit I: Interacts[Application], D: DataOps[Application]): Free[Application, Unit] = {

  import I._, D._

  for {
    cat <- ask("What's the kitty's name?")
    _ <- addCat(cat)
    cats <- getAllCats
    _ <- tell(cats.toString)
  } yield ()

}

@typeclass trait Capture[M[_]] {
  def capture[A](a: => A) : M[A]
}

implicit val taskCaptureInstance = new Capture[Task] {
  override def capture[A](a: => A): Task[A] = Task.evalOnce(a)
}

type Result[A] = Throwable Xor A

implicit val xorCaptureInstance = new Capture[Result] {
  override def capture[A](a: => A): Result[A] = Xor.catchNonFatal(a)
}

implicit val tryCaptureInstance = new Capture[Try] {
  override def capture[A](a: => A): Try[A] = Try(a)
}

class Interpreters[M[_] : Capture] {

  def InteractInterpreter: Interact ~> M = new (Interact ~> M) {
    def apply[A](i: Interact[A]) = i match {
      case Ask(prompt) => Capture[M].capture {
        println(prompt); "Tom"// scala.io.StdIn.readLine()
      }
      case Tell(msg) => Capture[M].capture(println(msg))
    }
  }

  def InMemoryDataOpInterpreter: DataOp ~> M = new (DataOp ~> M) {
    private[this] val memDataSet = new scala.collection.mutable.ListBuffer[String]

    def apply[A](fa: DataOp[A]) = fa match {
      case AddCat(a) =>
        Capture[M].capture { memDataSet.append(a); a }
      case GetAllCats() => Capture[M].capture(memDataSet.toList)
    }
  }

  def interpreter: Application ~> M =
    InteractInterpreter or InMemoryDataOpInterpreter

}

val xorInterpreter = new Interpreters[Result].interpreter
val xorProgram = program foldMap xorInterpreter

val taskInterpreter = new Interpreters[Task].interpreter
val taskProgram = program foldMap taskInterpreter

val tryInterpreter = new Interpreters[Try].interpreter
val tryProgram = program foldMap tryInterpreter

Hi Raul, it's awesome to see haskell code from you! :-)

I suggest to add:

!/usr/bin/env stack

-- stack --install-ghc runghc --package mtl --package free

in FreeComposition.hs in order to get an easy download-&-play

See you soon in lambda.world