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
You can’t perform that action at this time.