Pipe composition based on adjunctions.

composeAdj.hs

import Control.Monad.Free
import Data.Functor.Coproduct
import Data.Functor.Adjunction

combine :: Adjunction f u => u a -> f b -> (a, b)
combine ua = rightAdjunct (\b -> fmap (\a -> (a, b)) ua)

type Pipe f u r = Free (Coproduct f u) r

compose :: (Functor g, Functor v, Adjunction f u) => Pipe g u r -> Pipe f v r -> Pipe g v r
compose (Free (Coproduct (Left gp))) p2 = Free (Coproduct (Left (fmap (`compose` p2) gp)))
compose p1 (Free (Coproduct (Right vp))) = Free (Coproduct (Right (fmap (p1 `compose`) vp)))
compose (Free (Coproduct (Right up))) (Free (Coproduct (Left fp))) = uncurry compose (combine up fp)
compose (Pure r) _ = Pure r
compose _ (Pure r) = Pure r