Category Type Class

gistfile1.hs

Main.hs

{-# LANGUAGE FunctionalDependencies, DataKinds, GADTs, PolyKinds, KindSignatures, MultiParamTypeClasses #-}

module Main where

import Data.Monoid

import Prelude (Maybe(..))
import qualified Prelude as P

class Category (arr :: k -> k -> *) where
  id :: arr t t
  (.) :: arr b c -> arr a b -> arr a c

instance Category (->) where
  id = P.id
  (.) = (P..)

-- Every monoid is a category with one object

data M = M

data MFun m (a :: M) (b :: M) where
  MFun :: m -> MFun m a b

instance (Monoid m) => Category (MFun m) where
  id = MFun mempty
  MFun m1 . MFun m2 = MFun (m1 `mappend` m2)

-- Product category

data PairFun arr1 arr2 a b = PairFun (arr1 a b) (arr2 a b)

instance (Category arr1, Category arr2) => Category (PairFun arr1 arr2) where
  id = PairFun id id
  PairFun f1 f2 . PairFun g1 g2 = PairFun (f1 . g1) (f2 . g2)

-- Functors

class HFunctor dom cod f | f -> dom cod where
  hmap :: dom a b -> cod (f a) (f b)

instance HFunctor (->) (->) Maybe where
  hmap _ Nothing = Nothing
  hmap f (Just a) = Just (f a)

-- Embed a monoid in Hask

data Realize m (x :: M) where
  Realize :: m -> Realize m x

instance (Monoid m) => HFunctor (MFun m) (->) (Realize m) where
  hmap (MFun m1) (Realize m2) = Realize (m1 `mappend` m2)