FreeKeyValueStore.scala

sealed trait KeyValueStore[+A] {
  def map[B](f: A => B): KeyValueStore[B] =
    this match {
      case Put(k, v, q) => Put(k, v, f compose q)
      case Get(k, q) => Get(k, f compose q)
      case Del(k, q) => Del(k, f compose q) 
    }
}
case class Put[A](k: String, v: String, q: Option[String] => A) extends KeyValueStore[A]
case class Get[A](k: String, q: Option[String] => A) extends KeyValueStore[A]
case class Del[A](k: String, q: Option[String] => A) extends KeyValueStore[A]

object KeyValueStore {
  implicit val KeyValueStoreFunctor: Functor[KeyValueStore] =
    new Functor[KeyValueStore] {
      def fmap[A, B](f: A => B) =
        _ map f
    }
}

trait Functor[F[+_]] {
  def fmap[A, B](f: A => B): F[A] => F[B]
}

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

case class Cont[F[+_], +A](x: F[Free[F, A]]) extends Resume[F, A]
case class Term[F[+_], +A](x: A) extends Resume[F, A]
 
sealed trait Resume[F[+_], +A] {
  def map[B](f: A => B)(implicit F: Functor[F]): Resume[F, B] =
    this match {
      case Cont(x) => 
        Cont(F.fmap((_: Free[F, A]) map f)(x))
      case Term(a) =>
        Term(f(a))
    }

  def free: Free[F, A] =
    this match {
      case Cont(x) =>
        More(x)
      case Term(a) =>
        Done(a)
    }

  def term: Option[A] = 
    this match {
      case Cont(_) =>
        None
      case Term(a) =>
        Some(a)
    }

  def termOr[AA >: A](a: => AA): AA =
    term getOrElse a

  def cont: Option[F[Free[F, A]]] =
    this match {
      case Cont(x) =>
        Some(x)
      case Term(a) =>
        None
    }

  def contOr[AA >: A](x: => F[Free[F, AA]]): F[Free[F, AA]] =
    cont getOrElse x

}

private case class Done[F[+_], +A](a: A) extends Free[F, A]
private case class More[F[+_], +A](a: F[Free[F, A]]) extends Free[F, A]
// a.k.a. codensity hack. Scala does not have proper TCO.
private case class Bind[F[+_], A, +B](x: () => Free[F, A], f: A => Free[F, B]) extends Free[F, B]

sealed trait Free[F[+_], +A] {
  def map[X](f: A => X)(implicit F: Functor[F]): Free[F, X] =
    flatMap(a => Done(f(a)))

  def flatMap[X](f: A => Free[F, X])(implicit F: Functor[F]): Free[F, X] =
    this match {      
      case Bind(x, g) =>
        Bind(x, (x: Any) => Bind(() => g(x), f))
      case _ =>
        Bind(() => this, f)
    }
    /*
    // flatMap proper: no codensity hack
    this match {
      case Done(a) => f(a)
      case More(k) => More(F.fmap((_: Free[F, A]) flatMap f)(k))
    }
    */

  @annotation.tailrec
  final def resume(implicit F: Functor[F]): Resume[F, A] =
    this match {
      case Done(a) =>
        Term(a)        
      case More(a) =>
        Cont(a)
      case Bind(x, f) => 
        x() match {
          case Done(a) =>
            f(a).resume
          case More(a) => 
            Cont(F.fmap((_: Free[F, Any]) flatMap f)(a))
          case Bind(y, g) =>
            y().flatMap((x: Any) => g(x) flatMap f).resume
        }
    }

  def maps[G[+_]](f: F ~> G)(implicit F: Functor[F], G: Functor[G]): Free[G, A] =
    resume match {
      case Cont(x) => 
        More(f(F.fmap((_: Free[F, A]) maps f)(x)))
      case Term(a) =>
        Done(a)
    }

  def mapf(f: F ~> F)(implicit F: Functor[F]): Free[F, A] =
    resume match {
      case Cont(x) => 
        More(f(x))
      case Term(a) =>
        Done(a)
    }

  final def go[AA >: A](f: F[Free[F, AA]] => Free[F, AA])(implicit F: Functor[F]): AA = {
    @annotation.tailrec def go2(t: Free[F, AA]): AA = t.resume match {
      case Cont(x) => go2(f(x))
      case Term(a) => a
    }
    go2(this)
  }

}

case class FreeKeyValueStore[+A](free: Free[KeyValueStore, A]) {
  def map[X](f: A => X): FreeKeyValueStore[X] =
    FreeKeyValueStore(free map f)

  def flatMap[X](f: A => FreeKeyValueStore[X]): FreeKeyValueStore[X] =
    FreeKeyValueStore(free flatMap (f(_).free))

  final def resume: Resume[KeyValueStore, A] =
    free.resume

  // CAUTION
  // Unsafe operation. Run once only.
  @annotation.tailrec 
  final def runJHashMap(m: java.util.HashMap[String, String]): A =
    resume match {
      case Cont(Put(k, v, q)) =>
        FreeKeyValueStore(q(Option(m put (k, v)))) runJHashMap m
      case Cont(Get(k, q)) =>
        FreeKeyValueStore(q(Option(m get k))) runJHashMap m
      case Cont(Del(k, q)) =>
        FreeKeyValueStore(q(Option(m remove k))) runJHashMap m
      case Term(a) =>
        a      
    }
}

object FreeKeyValueStore {
  def put(k: String, v: String): FreeKeyValueStore[Option[String]] =
    FreeKeyValueStore(More(Put(k, v, Done(_))))
   
  def get(k: String): FreeKeyValueStore[Option[String]] =
    FreeKeyValueStore(More(Get(k, Done(_))))

  def del(k: String): FreeKeyValueStore[Option[String]] =
    FreeKeyValueStore(More(Del(k, Done(_))))
}

object Main {
  def main(args: Array[String]) {
    val conf = new java.util.HashMap[String, String]
    conf put ("ak", "av")
    conf put ("bk", "bv")
    conf put ("ck", "cv")

    import FreeKeyValueStore._

    val a0 = get("ak")
    val a1 = get("akX")
    val a2 = del("akX")
    val a3 = put("akX", "avX")
    val a4 = get("ak")
    val a5 = get("akX")
    val a6 = del("akX")
    val a7 = get("akX")
    val a8 = get("ak")
    val a9 = put("ak", "AV")

    val q: FreeKeyValueStore[List[Option[String]]] =
      for {
        e0 <- a0
        e1 <- a1
        e2 <- a2
        e3 <- a3
        e4 <- a4
        e5 <- a5
        e6 <- a6
        e7 <- a7
        e8 <- a8
        e9 <- a9        
      } yield List(e0, e1, e2, e3, e4, e5, e6, e7, e8, e9)

    val r = q runJHashMap conf

    r.zipWithIndex foreach {
      case (i, j) => println(j + ": " + i)
    }
  }
}