module Control.Category.Cartesian where

import Control.Category.Monoidal

import Control.Category ((>>>))

class MonoidalProduct k => Cartesian k where
  (&&&) :: (a `k` l) -> (a `k` r) -> (a `k` (l, r))
  k a l
l &&& k a r
r = k a (a, a)
forall (k :: * -> * -> *) a. Cartesian k => k a (a, a)
copy k a (a, a) -> k (a, a) (l, r) -> k a (l, r)
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (k a l
l k a l -> k a r -> k (a, a) (l, r)
forall (k :: * -> * -> *) al bl ar br.
MonoidalProduct k =>
k al bl -> k ar br -> k (al, ar) (bl, br)
*** k a r
r)
  consume :: a `k` ()
  copy :: a `k` (a, a)
  fst' :: (l, r) `k` l
  snd' :: (l, r) `k` r

instance Cartesian (->) where
  copy :: a -> (a, a)
copy a
x = (a
x, a
x)
  consume :: a -> ()
consume a
_ = ()
  fst' :: (l, r) -> l
fst' = (l, r) -> l
forall l r. (l, r) -> l
fst
  snd' :: (l, r) -> r
snd' = (l, r) -> r
forall l r. (l, r) -> r
snd

class MonoidalSum k => Cocartesian k where
  (|||) :: (al `k` b) -> (ar `k` b) -> (Either al ar `k` b)
  (|||) k al b
l k ar b
r = (k al b
l k al b -> k ar b -> k (Either al ar) (Either b b)
forall (k :: * -> * -> *) al bl ar br.
MonoidalSum k =>
k al bl -> k ar br -> k (Either al ar) (Either bl br)
+++ k ar b
r) k (Either al ar) (Either b b)
-> k (Either b b) b -> k (Either al ar) b
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> k (Either b b) b
forall (k :: * -> * -> *) a. Cocartesian k => k (Either a a) a
unify

  injectL :: a `k` (Either a b)
  injectR :: a `k` (Either b a)
  unify :: Either a a `k` a
  -- | tags 'Right' when 'True', 'Left' when 'False'
  tag :: k (Bool, a) (Either a a)

instance Cocartesian (->) where
  injectL :: a -> Either a b
injectL = a -> Either a b
forall a b. a -> Either a b
Left
  injectR :: a -> Either b a
injectR = a -> Either b a
forall a b. b -> Either a b
Right
  unify :: Either a a -> a
unify = (a -> a) -> (a -> a) -> Either a a -> a
forall al b ar. (al -> b) -> (ar -> b) -> Either al ar -> b
either a -> a
forall a. a -> a
id a -> a
forall a. a -> a
id
  tag :: (Bool, a) -> Either a a
tag (Bool
True, a
a) = a -> Either a a
forall a b. b -> Either a b
Right a
a
  tag (Bool
False, a
a) = a -> Either a a
forall a b. a -> Either a b
Left a
a