Play with adjunctions, specifically with composing Writer -| Reader

adjunction.scala

adjunction

import cats._

abstract class Adjunction[F[_], G[_]] { self =>

  def left[A,B](a: A)(f: F[A] => B): G[B]
  def right[A,B](fa: F[A])(f: A => G[B]): B

  def unit[A](a: A): G[F[A]] =
    left(a)(identity)

  def counit[A](fga: F[G[A]]): A =
    right(fga)(identity)

  /**
   * given any two adjoint functors, we can create a monad of their composite
   */
  def monad(implicit G: Functor[G]): Monad[({type λ[α] = G[F[α]]})#λ] =
    new Monad[({type λ[α] = G[F[α]]})#λ] {
      def pure[A](a: A) = unit(a)
      def flatMap[A,B](gfa: G[F[A]])(f: A => G[F[B]]): G[F[B]] =
      G.map(gfa)(right(_)(f))
    }

  /**
   * we can compose one adjunction with another
   */
  def compose[H[_], I[_]](HI: Adjunction[H, I]):
      Adjunction[({type λ[α] = H[F[α]]})#λ, ({type λ[α] = G[I[α]]})#λ] = {

    new Adjunction[({type λ[α] = H[F[α]]})#λ, ({type λ[α] = G[I[α]]})#λ] {

      def left[A,B](a: A)(f: H[F[A]] => B): G[I[B]] = 
        self.left(a)(HI.left(_)(f))

      def right[A,B](hfa: H[F[A]])(f: A => G[I[B]]): B =
        HI.right(hfa)(self.right(_)(f))
    }
  }
}

object ComposedState {
  def writerReader[S]: Adjunction[(S,?), S => ?] =
    new Adjunction[(S,?), S => ?] {
      def left[A, B](a: A)(f: ((S, A)) => B): S => B = s => f((s,a))
      def right[A,B](sa: (S,A))(f: A => S => B): B = f(sa._2)(sa._1)
    }

  type State[S,A] = S => (S, A)
  type Stateful[S, A, B] = A => State[S,B]

  type ComposedState[S1,S2,A] = S1 => (S2 => (S2, (S1, A)))

  def composeAdjMonad[S1,S2]: Monad[ComposedState[S1,S2, ?]] = {
//  Functor#compose seems to be broken in cats because it conflicts with Invariant#compose
//    val f1: Functor[S1 => ?] = cats.std.function.function1Covariant
//    val f2: Functor[S2 => ?] = cats.std.function.function1Covariant
//    implicit val f3: Functor[({type λ[α] = S1 => (S2 => α)})#λ] = f1.compose(f2)
    implicit val f3 = new Functor[({type λ[α] = S1 => (S2 => α)})#λ] {
      override def map[A,B](fa: S1 => (S2 => A))(f: A => B) = s1 => s2 => f(fa(s1)(s2))
    }

    (writerReader[S1].compose[(S2,?), S2 => ?](writerReader[S2])).monad
  }

  /**
   * combine two A => S => (S,B) functions that perfom stateful
   * computation on As such that a structure of As can be traversed
   * once doing both computations.
   */
  def twoInParallel[A,S1,S2,B,C,R](sf1: Stateful[S1,A,B],
                                   sf2: Stateful[S2,A,C],
                                   f: (B,C) => R): A => ComposedState[S1,S2,R] = 
    (a: A) => s1 => s2 => {
      val (ns2,c) = sf2(a)(s2)
      val (ns1,b) = sf1(a)(s1)
      (ns2, (ns1, f(b,c)))
    }


  /**
   * combine an A => S1 => (S1,B) with a B => S2 => (S2, B) so that
   * one traversal of As can compute a C, using both stateful
   * computations.
   */
  def feedOneAnother[A, S1, S2, B, C](sf1: Stateful[S1,A,B],
                                      sf2: Stateful[S2,B,C]):
      A => ComposedState[S1,S2,C] = a => s1 => s2 => {
    val (ns1,b) = sf1(a)(s1)
    val (ns2,c) = sf2(b)(s2)
    (ns2, (ns1, c))
  }

  /**
   * traverse an F full of As with a composite stateful computation
   */
  def traverseS2[F[_], S1, S2, A, C](fa: F[A])(s: A => ComposedState[S1, S2, C])(s1: S1, s2: S2)(implicit F: Traverse[F]): (S1, S2, F[C]) = {
    val st = F.traverse[ComposedState[S1,S2,?], A, C](fa)(s)(composeAdjMonad[S1,S2])
    val (ns2, (ns1, c)) = st(s1)(s2)
    (ns1, ns2, c)
  }
 }