Categorical functors with composition and identity

category.hs

{-# LANGUAGE TypeOperators, TypeFamilies, EmptyDataDecls, UndecidableInstances, RankNTypes, FlexibleContexts #-}

import Prelude hiding ((.), id)
import Control.Category
import Control.Arrow (Kleisli(..))

type family Obj (f :: * -> *) a :: *
class CFunctor f where
  type Dom f :: * -> * -> *
  type Cod f :: * -> * -> *
  (%) :: f x -> Dom f a b -> Cod f (Obj f a) (Obj f b)

type instance Obj [] a = [a]
instance CFunctor [] where
  type Dom [] = (->)
  type Cod [] = (->)
  [] % f = map f

type instance Obj Maybe a = Maybe a
maybe = Nothing -- readable type witness
instance CFunctor Maybe where
  type Dom Maybe = (->)
  type Cod Maybe = (->)
  (maybe % f) Nothing = Nothing
  (maybe % f) (Just x) = Just (f x)

data Id ((~>) :: * -> * -> *) a = Id
type instance Obj (Id (~>)) a = a
instance CFunctor (Id (~>)) where
  type Dom (Id (~>)) = (~>)
  type Cod (Id (~>)) = (~>)
  Id % f = f
  
data Comp g h a = Comp (forall x. g x) (forall x. h x)
type instance Obj (Comp g h) a = Obj g (Obj h a)
instance (CFunctor g, CFunctor h, Cod h ~ Dom g) => CFunctor (Comp g h) where
  type Dom (Comp g h) = Dom h
  type Cod (Comp g h) = Cod g
  Comp g h % f = g % (h % f)
  
test1 = (Comp [] [] % (+1)) [[1], [2, 3]]
test2 = (Comp Id Id % (+1)) 2

data KleisliArr (m :: * -> *) a = KleisliArr
type instance Obj (KleisliArr m) a = a
instance Monad m => CFunctor (KleisliArr m) where
  type Dom (KleisliArr m) = (->)
  type Cod (KleisliArr m) = Kleisli m
  KleisliArr % f = Kleisli (return . f)
  
-- Natural transformations
type s :~> t = forall c. 
  (CFunctor s, CFunctor t, Dom s ~ Dom t, Cod s ~ Cod t) => 
    Cod s (Obj s c) (Obj t c)
    
maybeToList :: Maybe :~> []
maybeToList (Just x) = [x]
maybeToList Nothing = []