Beyond Category

Category.hs

{-# LANGUAGE NoImplicitPrelude, TypeOperators #-}

import Prelude(undefined, Either(..), either, Functor(..))

data Store a b =
  Store (a -> b) a

instance Functor (Store a) where
  fmap f (Store p g) =
    Store (f . p) g

data a :@ b =
  Lens (a -> Store b a)

class Semigroupoid (~>) where
  (.) ::
    b ~> c
    -> a ~> b
    -> a ~> c

class Semigroupoid (~>) => Category (~>) where
  id ::
    a ~> a

instance Semigroupoid (->) where
  f . g =
    \x -> f (g x)

instance Category (->) where
  id a =
    a

instance Semigroupoid (:@) where
  Lens x . Lens y =
    Lens (\i -> let Store p q = y i
                    Store r s = x q
                in Store (p . r) s)

-- what constraints belong here?
class Tensor (~>) where
  (***) ::
    a ~> b
    -> c ~> d
    -> (a, c) ~> (b, d)

-- what constraints belong here?
class Disjoint (~>) where
  (|||) ::
    a ~> b
    -> c ~> d
    -> Either a c ~> Either b d

-- what constraints belong here?
class Choice (~>) where
  (.|.) ::
    a ~> x
    -> b ~> x
    -> Either a b ~> x

-- what constraints belong here?
class Combine (~>) where
  (.*.) ::
    a ~> x
    -> b ~> x
    -> (a, b) ~> x

-- what constraints belong here?
class Cochoice (~>) where
  (|.|) ::
    a ~> x
    -> b ~> x
    -> x ~> Either a b

-- what constraints belong here?
class Cocombine (~>) where
  (*.*) ::
    a ~> x
    -> b ~> x
    -> x ~> (a, b)

instance Tensor Store where
  Store a b *** Store c d =
    Store (\(a', c') -> (a a', c c')) (b, d)

instance Tensor (:@) where
  Lens x *** Lens y =
    Lens (\(i, j) -> x i *** y j)

instance Choice (:@) where
  Lens x .|. Lens y =
    Lens (either (fmap Left . x) (fmap Right . y))