content: {-# LANGUAGE PolyKinds, DataKinds #-}
  {-# LANGUAGE MultiParamTypeClasses, TypeFamilies #-}
  module CatPairs where
  
  import Prelude hiding (id, (.))
  import Data.Kind (Type)
  import Control.Monad ((>=>))
  import Control.Category
  
  -- Categories over pairs of types.
  -- Taken from Twan van Laarhoven:
  --   http://twanvl.nl/blog/haskell/categories-over-pairs-of-types
  
  type family Fst (xy :: (Type, Type)) :: Type
  type family Snd (xy :: (Type, Type)) :: Type
  type instance Fst '(x,y) = x
  type instance Snd '(x,y) = y
  
  -- Ceci n'est pas une pipe
  data Pipe i o u m r = Pipe { runPipe :: Either i u -> m (Either o r) }
  
  (>+>) :: Monad m
        => Pipe io1 io2 ur1 m ur2
        -> Pipe io2 io3 ur2 m ur3
        -> Pipe io1 io3 ur1 m ur3
  (>+>) (Pipe f) (Pipe g) = Pipe (f >=> g)
  
  idP :: Monad m => Pipe i i r m r
  idP = Pipe return
  
  newtype WrapPipe m iu or = WrapPipe
      { unWrapPipe :: Pipe (Fst iu) (Fst or) (Snd iu) m (Snd or) }
  
  instance Monad m => Category (WrapPipe m) where
    id    = WrapPipe idP
    x . y = WrapPipe (unWrapPipe y >+> unWrapPipe x)
  