Skip to content

Instantly share code, notes, and snippets.

@jsuereth
Last active October 26, 2022 14:19
Show Gist options
  • Save jsuereth/2916541ed8944fb134ae to your computer and use it in GitHub Desktop.
Save jsuereth/2916541ed8944fb134ae to your computer and use it in GitHub Desktop.
Freer monad in scala, just toying around.
trait Functor[F[_]] {
def map[A, B](fa: F[A])(f: A => B): F[B]
}
trait Monad[F[_]] {
def apply[A](a: A): F[A]
def flatMap[A,B](fa: F[A])(f: A => F[B]): F[B]
}
sealed trait FFree[G[x], A] {}
case class FPure[G[x], A](data: A) extends FFree[G, A]
case class FImpure[G[x], A, B](data: G[A], effect: A => FFree[G,B]) extends FFree[G,B]
object FFree {
def eta[G[x], A](fa : G[A]): FFree[G,A] =
FImpure(fa, FPure.apply _)
implicit def ffreeFunctor[G[x]]: Functor[({type L[x] = FFree[G,x]})#L] =
new Functor[({type L[x] = FFree[G,x]})#L] {
def map[A, B](fa: FFree[G,A])(f: A => B): FFree[G,B] =
fa match {
case FPure(data) => FPure[G,B](f(data))
case FImpure(data, effect) =>
// here we chain the function onto the effect. We may want to see if we can use some more complicated
// way of doing this which would be more efficient...
FImpure(data, /* (fmap f . effect) */ effect.andThen(out => map(out)(f)))
}
}
implicit def ffreeMonad[G[x]]: Monad[({type L[x] = FFree[G,x]})#L] =
new Monad[({type L[x] = FFree[G,x]})#L] {
def apply[A](a: A): FFree[G,A] = FPure(a)
def flatMap[A,B](fa: FFree[G,A])(f: A => FFree[G,B]): FFree[G,B] =
fa match {
case FPure(x) => f(x)
// here we chain the function onto the effect. We may want to see if we can use some more complicated
// way of doing this which would be more efficient...
case FImpure(data, effect) => FImpure(data, /* effect >>> f */effect.andThen(out => flatMap(out)(f)))
}
}
/* (>>>) :: Monad m => (a -> m b) -> (b -> m c) -> (a -> m c)
f >>> g = (>>= g) . f
*/
}
sealed trait State[S, X]
case class Get[S]() extends State[S,S]
case class Put[S](s: S) extends State[S, Unit]
object State {
type FState[S,A] = FFree[({type L[x]=State[S,x]})#L, A]
def get[S]: FState[S,S] = FFree.eta[({type L[x]=State[S,x]})#L, S](Get[S](): State[S,S])
def put[S](s: S): FState[S,Unit] = FFree.eta[({type L[x]=State[S,x]})#L, Unit](Put(s): State[S,Unit])
def test = {
val m = FFree.ffreeMonad[({type L[x]=State[Int,x]})#L]
val f = FFree.ffreeFunctor[({type L[x]=State[Int,x]})#L]
val x = put(5)
val y = f.map(x)(_ => "Hi")
val z = m.flatMap(y) { _ => get[Int] }
val z1 = f.map(z) { z => z + 1 }
run(z1)(0)
}
def run[S, A](f: FState[S,A])(s: S): (S,A) = {
/**unEffState :: StateEff s a -> (s -> (a,s))
unEffState Get s = (s,s)
unEffState (Put s) _ = ((),s)*/
def unEffState[X](s: State[S,X])(start: S): (S,X) =
s match {
case Get() => (start, start.asInstanceOf[X])
case Put(x) => (x, ().asInstanceOf[X])
}
f match {
case x: FPure[({type L[x]=State[S,x]})#L, A] => (s,x.data)
case x: FImpure[({type L[x]=State[S,x]})#L, _, A] =>
import x._
/* runEffState (FImpure m q) s =
let (x,s') = unEffState m s in runEffState (q x) s' */
val (sp, nextData) = unEffState(data)(s)
// TODO - trampoline and stuff.
run(effect(nextData))(sp)
}
}
}
import scala.language.higherKinds
import scala.language.existentials
/** A sequence of type aligned functions the look like an A => M[B]. */
sealed trait ContinuationQueue[M[_], A, B] {
/** Appends another continuation queue to this one. */
def ++[C](other: ContinuationQueue[M, B, C]): ContinuationQueue[M,A,C] =
Node(this, other)
/** Appends a new continuation to the queue. */
def :+[C](f: B => M[C]): ContinuationQueue[M,A,C] =
Node(this, Leaf(f))
}
/** A single continuation function. */
case class Leaf[M[_], A, B](f: A => M[B]) extends ContinuationQueue[M,A,B]
/** A chain of two continuation functions. */
case class Node[M[_], A, B, X](
lhs: ContinuationQueue[M,A,X],
rhs: ContinuationQueue[M,X,B]) extends ContinuationQueue[M,A,B]
object ContinuationQueue {
/** Constructs a continuation queue from a single continuation A => M[B]. */
def singleton[M[_], A, B](f: A => M[B]): ContinuationQueue[M,A,B] = Leaf(f)
/** Decomposes a continuation queue into head/tail components (lazily). */
def leftView[M[_], A, B](queue: ContinuationQueue[M,A,B]): ContinuationListView[M,A,B] =
queue match {
case Leaf(f) => TOne(f)
case Node(lhs, rhs) =>
def go[X](lhs: ContinuationQueue[M,A,X], rhs: ContinuationQueue[M, X,B]): ContinuationListView[M,A,B] =
(lhs, rhs) match {
case (Leaf(f), rhs) => TCons(f, rhs)
case (Node(l, l2), rhs) => go(l, l2 ++ rhs)
}
go(lhs,rhs)
}
}
// TODO - Decompose ContinuationQueue Left->Right, such that we get:
// 1. Single (A => M[B])
// 2. head: A => M[X]), tail: ContinuationQueue[M,X,B]
sealed trait ContinuationListView[M[_], A, B]
case class TOne[M[_], A, B](f: A => M[B]) extends ContinuationListView[M,A,B]
case class TCons[M[_], A, B, C](head: A => M[B], tail: ContinuationQueue[M,B,C]) extends ContinuationListView[M,A,C]
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment