Solution for "Bicategories in Haskell", replacing dependency on `Arr` with dependency on `Composable`

SO25210743.hs

{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
module SO25210743 where
import Prelude hiding (fmap, Functor, id, (.))
import GHC.Prim

class Category (c :: * -> * -> *) where
  id :: c x x
  (.) ::c y z -> c x y -> c x z

class Composable (cat :: * -> * -> *) (comp :: (* -> *) -> (* -> *) -> * -> *) where
  compose   :: forall f g x. cat (g (f x)) (comp g f x)
  uncompose :: forall f g x. cat (comp g f x) (g (f x))

class Functor c d f where
  fmap :: c x y -> d (f x) (f y)

newtype Compose (g :: * -> *) (f :: * -> *) (t :: *) = C (g (f t))

instance (Functor c d f, Functor d e g, Composable e Compose, Category e) => Functor c e (Compose g f) where
  -- c                      :: c x y
  -- fmap_cdf c             :: d (f x) (f y)
  -- fmap_deg (fmap_cdf c)  :: e (g (f x)) (g (f y))
  -- compose                :: e (g (f y)) (Compose g f y)
  -- uncompose              :: e (Compose g f x) (g (f x))
  -- compose . fmap_deg (fmap_cdf c) . uncompose 
  --                        :: e (Compose g f x) (Compose g f y)
  fmap c = compose . fmap_deg (fmap_cdf c) . uncompose
    where fmap_cdf :: forall x y. c x y -> d (f x) (f y)
          fmap_cdf = fmap
          fmap_deg :: forall x y. d x y -> e (g x) (g y)
          fmap_deg = fmap

newtype NT c f g = NT { unNT :: forall x. c (f x) (g x) }

class Bicategory (bicat :: (* -> * -> *) -> (* -> *) -> (* -> *) -> *) comp where
  id1   :: Category c => bicat c f f
  (.|)  :: Category c => bicat c g h -> bicat c f g -> bicat c f h
  (.-)  :: (Functor c d g, Composable d comp, Category d) => bicat d g g' -> bicat c f f' -> bicat d (comp g f) (comp g' f')

instance Bicategory NT Compose where
  id1 = NT id
  NT n .| NT m = NT (n . m)
  -- m              :: c (f x) (f' x)
  -- fmap m         :: d (g (f x)) (g (f' x))
  -- n              :: d (g (f' x)) (g' (f' x))
  -- n . fmap m     :: d (g (f x)) (g' (f' x))
  -- compose        :: d (g' (f' x)) (Compose g' f' x)
  -- uncompose      :: d (Compose g f x) (g (f x))
  -- compose . n . fmap m . uncompose
  --                :: d (Compose g f x) (Compose g' f' x)
  NT n .- NT m = NT $ compose . n . fmap m . uncompose