{-# LANGUAGE TypeFamilies, TypeOperators, GADTs, FlexibleContexts, NoImplicitPrelude #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Data.Category.Coproduct
-- License     :  BSD-style (see the file LICENSE)
--
-- Maintainer  :  sjoerd@w3future.com
-- Stability   :  experimental
-- Portability :  non-portable
-----------------------------------------------------------------------------
module Data.Category.Coproduct where

import Data.Category
import Data.Category.Functor

import Data.Category.NaturalTransformation
import Data.Category.Product
import Data.Category.Unit


data I1 a
data I2 a

data (:++:) :: (* -> * -> *) -> (* -> * -> *) -> * -> * -> * where
  I1 :: c1 a1 b1 -> (:++:) c1 c2 (I1 a1) (I1 b1)
  I2 :: c2 a2 b2 -> (:++:) c1 c2 (I2 a2) (I2 b2)

-- | The coproduct category of categories @c1@ and @c2@.
instance (Category c1, Category c2) => Category (c1 :++: c2) where
  
  src (I1 a)      = I1 (src a)
  src (I2 a)      = I2 (src a)
  tgt (I1 a)      = I1 (tgt a)
  tgt (I2 a)      = I2 (tgt a)

  (I1 a) . (I1 b) = I1 (a . b)
  (I2 a) . (I2 b) = I2 (a . b)

  
  
    
data Inj1 (c1 :: * -> * -> *) (c2 :: * -> * -> *) = Inj1
type instance Dom (Inj1 c1 c2) = c1
type instance Cod (Inj1 c1 c2) = c1 :++: c2
type instance Inj1 c1 c2 :% a = I1 a
-- | 'Inj1' is a functor which injects into the left category.
instance (Category c1, Category c2) => Functor (Inj1 c1 c2) where 
  Inj1 % f = I1 f

data Inj2 (c1 :: * -> * -> *) (c2 :: * -> * -> *) = Inj2
type instance Dom (Inj2 c1 c2) = c2
type instance Cod (Inj2 c1 c2) = c1 :++: c2
type instance Inj2 c1 c2 :% a = I2 a
-- | 'Inj2' is a functor which injects into the right category.
instance (Category c1, Category c2) => Functor (Inj2 c1 c2) where 
  Inj2 % f = I2 f

data f1 :+++: f2 = f1 :+++: f2
type instance Dom (f1 :+++: f2) = Dom f1 :++: Dom f2
type instance Cod (f1 :+++: f2) = Cod f1 :++: Cod f2
type instance (f1 :+++: f2) :% (I1 a) = I1 (f1 :% a)
type instance (f1 :+++: f2) :% (I2 a) = I2 (f2 :% a)
-- | @f1 :+++: f2@ is the coproduct of the functors @f1@ and @f2@.
instance (Functor f1, Functor f2) => Functor (f1 :+++: f2) where 
  (g :+++: _) % I1 f = I1 (g % f)
  (_ :+++: g) % I2 f = I2 (g % f)
  
data CodiagCoprod (k :: * -> * -> *) = CodiagCoprod
type instance Dom (CodiagCoprod k) = k :++: k
type instance Cod (CodiagCoprod k) = k
type instance CodiagCoprod k :% I1 a = a
type instance CodiagCoprod k :% I2 a = a
-- | 'CodiagCoprod' is the codiagonal functor for coproducts.
instance Category k => Functor (CodiagCoprod k) where 
  CodiagCoprod % I1 f = f
  CodiagCoprod % I2 f = f

data Cotuple1 (c1 :: * -> * -> *) (c2 :: * -> * -> *) a = Cotuple1 (Obj c1 a)
type instance Dom (Cotuple1 c1 c2 a1) = c1 :++: c2
type instance Cod (Cotuple1 c1 c2 a1) = c1
type instance Cotuple1 c1 c2 _1 :% I1 a1 = a1
type instance Cotuple1 c1 c2 a1 :% I2 a2 = a1
-- | 'Cotuple1' projects out to the left category, replacing a value from the right category with a fixed object.
instance (Category c1, Category c2) => Functor (Cotuple1 c1 c2 a1) where
  Cotuple1 _ % I1 f = f
  Cotuple1 a % I2 _ = a

data Cotuple2 (c1 :: * -> * -> *) (c2 :: * -> * -> *) a = Cotuple2 (Obj c2 a)
type instance Dom (Cotuple2 c1 c2 a2) = c1 :++: c2
type instance Cod (Cotuple2 c1 c2 a2) = c2
type instance Cotuple2 c1 c2 a2 :% I1 a1 = a2
type instance Cotuple2 c1 c2 _2 :% I2 a2 = a2
-- | 'Cotuple2' projects out to the right category, replacing a value from the left category with a fixed object.
instance (Category c1, Category c2) => Functor (Cotuple2 c1 c2 a2) where
  Cotuple2 a % I1 _ = a
  Cotuple2 _ % I2 f = f


data (:>>:) :: (* -> * -> *) -> (* -> * -> *) -> * -> * -> * where
  I1A :: c1 a1 b1 -> (:>>:) c1 c2 (I1 a1) (I1 b1)
  I12 :: Obj c1 a -> Obj c2 b -> (:>>:) c1 c2 (I1 a) (I2 b)
  I2A :: c2 a2 b2 -> (:>>:) c1 c2 (I2 a2) (I2 b2)

-- | The directed coproduct category of categories @c1@ and @c2@.
instance (Category c1, Category c2) => Category (c1 :>>: c2) where

  src (I1A a)   = I1A (src a)
  src (I12 a _) = I1A a
  src (I2A a)   = I2A (src a)
  tgt (I1A a)   = I1A (tgt a)
  tgt (I12 _ b) = I2A b
  tgt (I2A a)   = I2A (tgt a)

  (I1A a) . (I1A b) = I1A (a . b)
  (I12 _ a) . (I1A b) = I12 (src b) a
  (I2A a) . (I12 b _) = I12 b (tgt a)
  (I2A a) . (I2A b) = I2A (a . b)




data NatAsFunctor f g = NatAsFunctor (Nat (Dom f) (Cod f) f g)
type instance Dom (NatAsFunctor f g) = Dom f :**: (Unit :>>: Unit)
type instance Cod (NatAsFunctor f g) = Cod f
type instance NatAsFunctor f g :% (a, I1 ()) = f :% a
type instance NatAsFunctor f g :% (a, I2 ()) = g :% a
-- | A natural transformation @Nat c d@ is isomorphic to a functor from @c :**: 2@ to @d@.
instance (Functor f, Functor g, Dom f ~ Dom g, Cod f ~ Cod g) => Functor (NatAsFunctor f g) where
  NatAsFunctor (Nat f _ _) % (a :**: I1A Unit) = f % a
  NatAsFunctor (Nat _ g _) % (a :**: I2A Unit) = g % a
  NatAsFunctor n           % (a :**: I12 Unit Unit) = n ! a