The free monad in (almost) real life

Now that we have a fairly good understanding of what the free monad is and how it works. Let’s see what it looks like to write a real program based on this concept. This time we won’t implement Free ourselves but use the cats library for that. If you don’t know all the theory behind the free monad and just want to see how to use it then read on as this post builds an application from scratch.

In this post we’ll write simple DSLs, lift them into the free monad and even combine them into one program. There is some boiler plate around but I want to get a feeling of what it looks like to combine more DSLs and see how we can architecture a whole application around the free monad.

Getting started

Let’s pretend that we are writing a stock management program to maintain an inventory of all the items inside a warehouse.

Let’s start by defining our DSL to manage the stock:

type LocationId      = String
type ProductId       = String
type PurchaseOrderId = String

object Stock {
  sealed trait Movement[A]
  // POContent list all the product and quantities inside a purchase order
  case class POContent(poId: PurchaseOrderId) 
    extends Movement[Map[ProductId, Int]]

  // Create some stock in a location
  case class CreateStock(
    productId: ProductId,
    locationId: LocationId,
    quantity: Int) extends Movement[Unit]  

  // Move some items from one location to the other
  case class MoveStock(
    productId: ProductId, 
    source: LocationId, 
    destination: LocationId, 
    quantity: Int) extends Movement[Unit]
}

This are our basic operations that we need in order to inbound some stock (i.e. receiving new products in the warehouse).
Before we can write our first program we need a way to lift our DSL into the Free monad.

import cats.free.Free
import cats.free.Free._

object Stock {
  // DSL definitions ....
 
  type MovementF[A] = Free[Movement, A]

  def poContent(poId: PurchaseOrderId): MovementF[Map[ProductId, Int]] = 
    liftF(POContent(poId))

  def createStock(
    productId: ProductId,
    locationId: LocationId,
    quantity: Int): MovementF[Unit] = 
    liftF(CreateStock(productId, locationId, quantity))

  def moveStock(
    productId: ProductId,
    source: LocationId,
    destination: LocationId,
    quantity: Int): MovementF[Unit] = 
    liftF(MoveStock(productId, source, destination, quantity))
}

And finally we can write our business logic.

import cats.implicits._

def inboundStock(poId: PurchaseOrderId): MovementF[Unit] = 
  for {
    content <- poContent(poId)
    _       <- content.toList.traverseU {
      case (productId, quantity) => 
        createStock(productId, "dock", quantity)
    }
    _       <- content.toList.traverseU {
      case (productId, quantity) => 
        moveStock(productId, "dock", "warehouse", quantity)
    }
  } yield ()

Here we receive a new purchase order, retrieve the products in the order and create the corresponding stock at the dock and then we move all the stock from the dock to the warehouse. This is our business logic but we can’t run it as we have yet to write an interpreter.

Let’s just create one that print all the actions to the console.

import cats.{ Id, ~> }
import Stock._
object StockConsole extends (Movement ~> Id) {
  def apply[A](movement: Movement[A]): Id[A] = movement match {
    case POContent(poId) =>
      println(s"Listing content of $poId: [200 Mars, 100 Milkyway, 150 Galaxy]")
      Map("Mars" -> 200, "Milkyway" -> 100, "Galaxy" -> 150)
    case CreateStock(productId, locationId, quantity) =>
      println(s"Creating $quantity $productId at $locationId")
    case MoveStock(productId, source, destination, quantity) =>
      println(s"Moving $quantity $productId from $source to $destination")
  }
}

At last we can execute it with:

inboundStock("po-1").foldMap(StockConsole)

and this is what we get on the console

Listing content of po-1: [200 Mars, 100 Milkyway, 150 Galaxy]
Creating 200 Mars at dock
Creating 100 Milkyway at dock
Creating 150 Galaxy at dock
Moving 200 Mars from dock to warehouse
Moving 100 Milkyway from dock to warehouse
Moving 150 Galaxy from dock to warehouse

Dealing with errors

Now let’s imagine that there is something wrong in our business logic

def inboundInvalidStock(poId: PurchaseOrderId): MovementF[Unit] = 
  for {
    content <- poContent(poId)
    _       <- content.toList.traverseU {
      case (productId, quantity) => 
        createStock(productId, "dock", quantity)
    }
    _       <- content.toList.traverseU {
      case (productId, quantity) => 
        // move 1 more items than we received in the order
        moveStock(productId, "dock", "warehouse", quantity + 1)
    }
  } yield ()

That’s not good we’re moving more items than we have received but our program runs just fine. We’d rather want it to report us an error in this case.
At this point we have 2 solutions. We can change MoveStock to extends Movement[Either[String, Unit]] but then we’ll have to modify our business logic to deal with the error case which I don’t want to. That leads us to the second solution: changing our interpreter to transform Movement[A] into Either[String, A].

// a Result can be either a an error (Left) or a valid result A (Right)
type Result[A] = Either[String, A]

object StockValidation extends (Movement ~> Result) {
  val content = Map("Mars" -> 200, "Milkyway" -> 100, "Galaxy" -> 150)
  def apply[A](movement: Movement[A]): Result[A] = movement match {
    case POContent(poId) =>
      println(s"Listing content of $poId: [200 Mars, 100 Milkyway, 150 Galaxy]")
      Right(content)
    case CreateStock(productId, locationId, quantity) =>
      println(s"Creating $quantity $productId at $locationId")
      Right(())
    case MoveStock(productId, source, destination, quantity) =>
      val isValid = content.get(productId).map(_ == quantity) getOrElse false
      if (isValid) {
        println(s"Moving $quantity $productId from $source to $destination")
        Right(())
      } else {
        println("Error: Invalid quantity")
        Left("Invalid quantity")
      }
  }
}

and we can run it with

inboundInvalidStock("po-1").foldMap(StockValidation)

And this time we got an error as soon as we try to move something to the warehouse

Listing content of po-1: [200 Mars, 100 Milkyway, 150 Galaxy]
Creating 200 Mars at dock
Creating 100 Milkyway at dock
Creating 150 Galaxy at dock
Error: Invalid quantity

Adding logs

Instead of using println directly in the interpreter we can define our own DSL for logging and add the logs to our program. Let’s do just that and then combine the logging instructions with the stock instructions.

object Logging {
  sealed trait Log[A]
  case class Info(message: String) extends Log[Unit]
  case class Error(message: String) extends Log[Unit]
}

Simple enough! But this time we can’t use liftF to lift into the Free monad. Why? Because we’re going to mix Log and Movement in our program so we want to lift into a Free[F, A] where F is the coproduct of Log and Movement.

import import cats.free.Inject

object Stock {
  // ....

  class Movements[F[_]](implicit i: Inject[Movement, F]) {
    def poContent(poId: PurchaseOrderId): Free[F, Map[ProductId, Int]] = 
      Free.inject[Movement, F](POContent(poId))
    
    def moveStock(
      productId: ProductId, 
      source: LocationId, 
      destination: LocationId, 
      quantity: Int): Free[F, Unit] =
      Free.inject[Movement, F](
        MoveStock(productId, source, destination, quantity)
      )
    
    def createStock(
      productId: ProductId, 
      locationId: LocationId, 
      quantity: Int): Free[F, Unit] =
      Free.inject[Movement, F](
        CreateStock(productId, locationId, quantity)
      )
  }

  object Movements {
    implicit def movements[F[_]](implicit i: Inject[Movement, F]): Movements[F] = 
      new Movements[F]
  }
}

object Logging {
  
  // ...

  class Logs[F[_]](implicit i: Inject[Log, F]) {

    def error(message: String): Free[F, Unit] = 
       Free.inject[Log, F](Error(message))

    def info(message: String): Free[F, Unit] = 
       Free.inject[Log, F](Info(message))
  }

  object Logs {
    implicit def logs[F[_]](implicit i: Inject[Log, F]): Logs[F] = new Logs[F]
  }
}

If you don’t really understand what’s going on here you can refer to the previous article where there is a longer explanation how inject lifts the operation into the Free monad with the correct type. (It’s just like liftF but with the correct type).

Alternatively you can consider this code as some boilerplate needed to make things work. There are even some plugins such as … that can generate this boilerplate for you.

Let’s write a basic console logger to interpret our logging DSL

import Logging._
object ConsoleLogger extends (Log ~> Id) {
  def apply[A](log: Log[A]): Id[A] = {
    val timestamp = System.currentTimeMillis()
    log match {
      case Error(message) =>
        println(s"[ERROR] [$timestamp] $message")
      case Info(message)  =>
        println(s"[INFO ] [$timestamp] $message")
    }
  }
}

We’re now ready to combine logs and movements into our inbound program.

import cats.data.Coproduct
import Stock._
import Logging._

type MovementOrLog[A] = Coproduct[Movement, Log, A]

def inboundStockWithLog(poId: PurchaseOrderId)(
  implicit movements: Movements[MovementOrLog], 
           logs: Logs[MovementOrLog]): Free[MovementOrLog, Unit] = {
  import movements._
  import logs._

  for {
    _       <- info(s"Inbounding $poId")
    content <- poContent(poId)
    _       <- content.toList.traverseU {
      case (productId, quantity) => 
        createStock(productId, "dock", quantity)
    }
    _       <- content.toList.traverseU {
      case (productId, quantity) => 
        moveStock(productId, "dock", "warehouse", quantity)
    }
  } yield ()
}

And we can even execute it

val stockConsoleWithLogging: MovementOrLog ~> Id = 
  StockConsole or ConsoleLogger
inboundStockWithLog("po-1").foldMap(StockConsoleWithLogging)

And we have our log message on the console

[INFO ] [1482098739890] Inbounding po-1
Listing content of po-1: [200 Mars, 100 Milkyway, 150 Galaxy]
Creating 200 Mars at dock
Creating 100 Milkyway at dock
Creating 150 Galaxy at dock
Moving 200 Mars from dock to warehouse
Moving 100 Milkyway from dock to warehouse
Moving 150 Galaxy from dock to warehouse

More complexity

Ultimately we’d like to track the inventory at each location. For that we need a way to update the inventory at a given location and we’re going to do it with … a new DSL.

object Inventory {

  sealed trait Update[A]
  case class Increment(locationId: LocationId, productId: ProductId, quantity: Int) 
    extends Update[Unit]
  case class Decrement(locationId: LocationId, productId: ProductId, quantity: Int) 
    extends Update[Unit]

  def increment(locationId: LocationId, productId: ProductId, quantity: Int): Free[Update, Unit] =
    liftF(Increment(locationId, productId, quantity))
  def decrement(locationId: LocationId, productId: ProductId, quantity: Int): Free[Update, Unit] =
    liftF(Decrement(locationId, productId, quantity))

  class Updates[F[_]](implicit i: Inject[Update, F]) {
    def increment(locationId: LocationId, productId: ProductId, quantity: Int): Free[F, Unit] = 
      Free.inject[Update, F](Increment(locationId, productId, quantity))
    def decrement(locationId: LocationId, productId: ProductId, quantity: Int): Free[F, Unit] = 
      Free.inject[Update, F](Decrement(locationId, productId, quantity))
  }

  object Updates {
    implicit def updates[F[_]](implicit i: Inject[Update, F]): Updates[F] = 
      new Updates[F]
  }
}

along with its interpreter

import Inventory._
object InventoryConsole extends (Update ~> Id) {
  def apply[A](update: Update[A]): Id[A] = {
    update match {
      case Increment(locationId, productId, quantity) =>
        println(s"Add $quantity $productId at $locationId")
      case Decrement(locationId, productId, quantity) =>
        println(s"Remove $quantity $productId from $locationId")
    }
  }
}

And let’s at this to our business logic

type MovementOrLogOrUpdate[A] = Coproduct[Update, MovementOrLog, A]
def inboundInventory(poId: PurchaseOrderId)(
  implicit movements: Movements[MovementOrLogOrUpdate], 
           logs: Logs[MovementOrLogOrUpdate], 
           updates: Updates[MovementOrLogOrUpdate]): Free[MovementOrLogOrUpdate, Unit] = {
  import movements._
  import logs._
  import updates._
  for {
    _        <- info(s"Inbounding $poId")
    contents <- poContent(poId)
    _        <- contents.toList.traverseU { 
      case (productId, quantity) =>
        createStock(productId, "dock", quantity)
          // when we create stock we increment to quantity at the location
          .flatMap(_ => increment("dock", productId, quantity))
      }
    _        <- contents.toList.traverseU {
      case (productId, quantity) =>
        moveStock(productId, "dock", "warehouse", quantity)
          // when we move stock we need to decrement the stock from the source
          .flatMap(_ => decrement("dock", productId, quantity))
          // and increment it at the destination
          .flatMap(_ => increment("warehouse", productId, quantity))
      }
    } yield ()
}

And finally let’s run it

val stockConsoleWithLoggingAndUpdate: MovementOrLogOrUpdate ~> Id = 
  InventoryConsole or stockConsoleWithLogging
inboundInventory("po-1").foldMap(stockConsoleWithLoggingAndUpdate)
[INFO ] [1482102639964] Inbounding po-1
Listing content of po-1: [200 Mars, 100 Milkyway, 150 Galaxy]
Creating 200 Mars at dock
  Add 200 Mars at dock
Creating 100 Milkyway at dock
  Add 100 Milkyway at dock
Creating 150 Galaxy at dock
  Add 150 Galaxy at dock
Moving 200 Mars from dock to warehouse
  Remove 200 Mars from dock
  Add 200 Mars at warehouse
Moving 100 Milkyway from dock to warehouse
  Remove 100 Milkyway from dock
  Add 100 Milkyway at warehouse
Moving 150 Galaxy from dock to warehouse
  Remove 150 Galaxy from dock
  Add 150 Galaxy at warehouse

I don’t know what you think but I am starting to feel a bit uncomfortable when I look at the business logic. It start to be bloated and not as clean and easy to read as it used to be. And we haven’t yet added any persistence to our program. Let’s do it to see how bad it gets and then we’ll see how we can clean this up.

Adding persistence

By now you should get used to it … let’s create another DSL

object Storage {
  sealed trait Query[A]
  case class Get[K, V](key: K) extends Query[Option[V]]
  case class Put[K, V](key: K, value: V) extends Query[Unit]

  class Queries[F[_]](implicit i: Inject[Query, F]) {
    def get[K, V](key: K): Free[F, Option[V]] =
      Free.inject[Query, F](Get(key))
    def put[K, V](key: K, value: V): Free[F, Unit] =
      Free.inject[Query, F](Put(key, value))
  }

  object Queries {
    implicit def queries[F[_]](implicit i: Inject[Query, F]) =
      new Queries[F]
  }
}

Then the interpreter that will just store the data in a map

import Storage._
object KeyValueStore extends (Query ~> Id) {
  var store: Map[Any, Any] = Map.empty
  def apply[A](query: Query[A]): Id[A] = query match {
    case Get(key)        => store.get(key)
    case Put(key, value) => store += key -> value
  }
}

And finally let’s try to update our program to store the product quantities in the map

type MovementOrLogOrUpdateOrQuery[A] = Coproduct[Query, MovementOrLogOrUpdate, A]

def persistInboundInventory(poId: PurchaseOrderId)(
  implicit movements: Movements[MovementOrLogOrUpdateOrQuery], 
           logs: Logs[MovementOrLogOrUpdateOrQuery], 
           updates: Updates[MovementOrLogOrUpdateOrQuery], 
           queries: Queries[MovementOrLogOrUpdateOrQuery]): Free[MovementOrLogOrUpdateOrQuery, Unit] = {
    import movements._
    import logs._
    import updates._
    import queries._
    for {
      _        <- info(s"Inbounding $poId")
      contents <- poContent(poId)
      _        <- contents.toList.traverseU { case (productId, quantity) =>
        createStock(productId, "dock", quantity)
          .flatMap(_ => increment("dock", productId, quantity))
          .flatMap(_ => get[String, Map[String, Int]]("dock").flatMap {
            case Some(products) => put("dock", products + (productId -> quantity))
            case None => put("dock", Map(productId -> quantity))
          })
      }
      _        <- contents.toList.traverseU {
        case (productId, quantity) =>
          moveStock(productId, "dock", "warehouse", quantity)
            .flatMap(_ => decrement("dock", productId, quantity))
            .flatMap(_ => increment("dock", productId, quantity))
            .flatMap(_ => get[String, Map[String, Int]]("dock").flatMap {
              case Some(products) => put("dock", products - productId)
              case None => pure(())
            })
            .flatMap(_ => get[String, Map[String, Int]]("warehouse").flatMap {
              case Some(products) => put("warehouse", products + (productId -> quantity))
              case None => put("warehouse", Map(productId -> quantity))
            })
      }
    } yield ()
  }

and finally let’s run it

val stockConsoleWithLoggingAndPersistentUpdate: MovementOrLogOrUpdateOrQuery ~> Id = 
  KeyValueStore or stockConsoleWithLoggingAndUpdate
persistInboundInventory("po-1").foldMap(stockConsoleWithLoggingAndPersistentUpdate)

It produces the same output as before but this time the product quantities at each location are stored in the map.
In a real world that would be a persistent storage (e.g. a database).

Adding perspective

I don’t know about you but I wouldn’t maintain this business logic. It doesn’t read well – no one can figure out what it does without a careful look.

In fact it’s because our architecture is not right. We have created a single layer containing all the operations.

It would have been much better to write the business logic using the Stock DSL. Then turn the Movement into more basic operation (i.e. Inventory updates) which can then be turned into Storage queries.

That would make the business much clearer but how can we combine this logic vertically rather than horizontally?

Well, what does an interpreter do? It transforms a data type into a monad and it turns out that the Free monad is a monad. So we can have an interpreter for Stock that generates a Free monad of inventory updates and then an inventory update interpreter that generates a Free monad containing the storing logic.

Let’s write these interpreters

type InventoryF[A] = Free[Update, A]
def movementInterpreter = 
  new (Movement ~> InventoryF) {
    def apply[A](movement: Movement[A]): InventoryF[A] = 
      movement match {
        case POContent(_) =>
          pure(Map("Mars" -> 200, "Milkyway" -> 100, "Galaxy" -> 150))
        case CreateStock(productId, locationId, quantity) =>
          increment(locationId, productId, quantity)
        case MoveStock(productId, source, destination, quantity) =>
          for {
            _ <- decrement(source, productId, quantity)
            _ <- increment(destination, productId, quantity)
          } yield ()
      }
  }

type StorageOrLog[A] = Coproduct[Query, Log, A]
type StorageOrLogF[A] = Free[StorageOrLog, A]
def inventoryInterpreter(implicit logs: Logs[StorageOrLog], queries: Queries[StorageOrLog]) = 
  new (Update ~> StorageOrLogF) {
    import logs._
    import queries._
    type Key = (LocationId, ProductId)
    def apply[A](update: Update[A]): StorageOrLogF[A] = {
      update match {
        case Increment(locationId, productId, quantity) =>
          for {
            _ <- info(s"Add $quantity $productId at $locationId")
            existing <- get[Key, Int]((locationId, productId)).map(_ getOrElse 0)
            _ <- put((locationId, productId), existing + quantity)
        } yield ()
        case Decrement(locationId, productId, quantity) =>
          for {
            _ <- info(s"Remove $quantity $productId from $locationId")
            existing <- get[Key, Int]((locationId, productId)).map(_ getOrElse 0)
            _ <- put((locationId, productId), existing - quantity)
          } yield ()
      }
    }
  }

Not too bad! Each interpreter is quite clear and understandable and we can even re-use our initial implementation to define the inbound operation.

def inboundStockWithLog(poId: PurchaseOrderId)(
  implicit movements: Movements[MovementOrLog], 
           logs: Logs[MovementOrLog]): MovementF[Unit] = {
  import movements._
  import logs._

  for {
    _       <- info("Inbounding $poId")
    content <- poContent(poId)
    _       <- content.toList.traverseU {
      case (productId, quantity) => 
        createStock(productId, "dock", quantity)
    }
    _       <- content.toList.traverseU {
      case (productId, quantity) => 
        moveStock(productId, "dock", "warehouse", quantity)
    }
  } yield ()
}

We are almost there – we just need to combine our interpreters into one that turns Movement into Id.
This is what we have so far:

  • movementInterpreter turns Movements into InventoryF
  • inventoryInterpreter turns Updates into StorageOrLogF
  • KeyValueStore turns Queries into Id
  • ConsoleLogger turns Logs into Id

We’re still missing some glue here. We got an InventoryF (i.e. Free[Update, A]) but our interpreter expects just an Update type. Fortunately the missing interpreters are easy to write as they just have to foldMap the free monad.

def inventoryFreeInterpreter(
  implicit logs: Logs[StorageOrLog], 
           queries: Queries[StorageOrLog]) = 
  new (InventoryF ~> StorageOrLogF) {
    def apply[A](inventoryF: InventoryF[A]): StorageOrLogF[A] = 
      inventoryF.foldMap(inventoryInterpreter)
  }

def storageOrLogFreeInterpreter = new (StorageOrLogF ~> Id) {
  def apply[A](fa: StorageOrLogF[A]): Id[A] = 
    fa.foldMap(KeyValueStore or ConsoleLogger)
  }

We can then combine them all

val stackInterpreter = 
  MovementInterpreter andThen inventoryFreeInterpreter andThen storageOrLogFreeInterpreter

and finally we can run our inbound program

inboundStockWithLog("po-1").foldMap(stackInterpreter or ConsoleLogger)
[INFO ] [1482103350405] Inbounding po-1
[INFO ] [1482103350408] Add 200 Mars at dock
[INFO ] [1482103350410] Add 100 Milkyway at dock
[INFO ] [1482103350410] Add 150 Galaxy at dock
[INFO ] [1482103350411] Remove 200 Mars from dock
[INFO ] [1482103350412] Add 200 Mars at warehouse
[INFO ] [1482103350413] Remove 100 Milkyway from dock
[INFO ] [1482103350413] Add 100 Milkyway at warehouse
[INFO ] [1482103350413] Remove 150 Galaxy from dock
[INFO ] [1482103350413] Add 150 Galaxy at warehouse

That’s much better! All the code is nicely separated and easy to follow.

Hopefully that gave you a taste of what is free-programing! There is still a bunch of boilerplate (more that I would like) – especially given that our example is quite simple after all.

You have to be very careful to combine the types and the interpreters (the order does matter a lot and the compilation errors are not always very explicit – at least for me).

And by the way, don’t trust IntelliJ as it sometimes shows inexistent errors (especially for the interpreters) so just compile your program as often as possible.