Skip to content

Instantly share code, notes, and snippets.

Embed
What would you like to do?
{-# 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 ()
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
@Softsapiens

This comment has been minimized.

Copy link

@Softsapiens Softsapiens commented Sep 28, 2016

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

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment