{-# OPTIONS_GHC -fno-warn-unused-imports #-}
{-# OPTIONS_HADDOCK show-extensions #-}
module Control.CatBifunctor
( CatBiFunctor,
first,
second,
(***),
)
where
import Control.Applicative (liftA2)
import Control.Arrow (Kleisli (Kleisli), (>>>))
import Control.Category (Category, id)
import Control.Comonad (Cokleisli (Cokleisli), Comonad, liftW)
import Data.Bifunctor (bimap)
import GHC.Base (Type)
import Prelude (Either (Left, Right), Monad, fmap, fst, snd, ($))
class
Category cat =>
CatBiFunctor (p :: Type -> Type -> Type) (cat :: Type -> Type -> Type)
where
(***) :: cat a1 b1 -> cat a2 b2 -> cat (p a1 a2) (p b1 b2)
first :: cat a b -> cat (p a c) (p b c)
first cat a b
f = cat a b
f cat a b -> cat c c -> cat (p a c) (p b c)
forall (p :: * -> * -> *) (cat :: * -> * -> *) a1 b1 a2 b2.
CatBiFunctor p cat =>
cat a1 b1 -> cat a2 b2 -> cat (p a1 a2) (p b1 b2)
*** cat c c
forall k (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id
second :: cat a b -> cat (p c a) (p c b)
second cat a b
f = cat c c
forall k (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id cat c c -> cat a b -> cat (p c a) (p c b)
forall (p :: * -> * -> *) (cat :: * -> * -> *) a1 b1 a2 b2.
CatBiFunctor p cat =>
cat a1 b1 -> cat a2 b2 -> cat (p a1 a2) (p b1 b2)
*** cat a b
f
instance CatBiFunctor (,) (->) where
first :: (a -> b) -> (a, c) -> (b, c)
first a -> b
f = (a -> b) -> (c -> c) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap a -> b
f c -> c
forall k (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id
second :: (a -> b) -> (c, a) -> (c, b)
second = (c -> c) -> (a -> b) -> (c, a) -> (c, b)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap c -> c
forall k (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id
*** :: (a1 -> b1) -> (a2 -> b2) -> (a1, a2) -> (b1, b2)
(***) = (a1 -> b1) -> (a2 -> b2) -> (a1, a2) -> (b1, b2)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap
instance forall m. Monad m => CatBiFunctor (,) (Kleisli m) where
(***) :: Kleisli m a1 b1 -> Kleisli m a2 b2 -> Kleisli m (a1, a2) (b1, b2)
(Kleisli (a1 -> m b1
mf1 :: a1 -> m b1)) *** :: Kleisli m a1 b1 -> Kleisli m a2 b2 -> Kleisli m (a1, a2) (b1, b2)
*** (Kleisli (a2 -> m b2
mf2 :: a2 -> m b2)) = ((a1, a2) -> m (b1, b2)) -> Kleisli m (a1, a2) (b1, b2)
forall (m :: * -> *) a b. (a -> m b) -> Kleisli m a b
Kleisli (a1, a2) -> m (b1, b2)
mf12
where
mf12 :: (a1, a2) -> m (b1, b2)
mf12 :: (a1, a2) -> m (b1, b2)
mf12 (a1
x1, a2
x2) = (b1 -> b2 -> (b1, b2)) -> m b1 -> m b2 -> m (b1, b2)
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (,) (a1 -> m b1
mf1 a1
x1) (a2 -> m b2
mf2 a2
x2)
instance forall m. Comonad m => CatBiFunctor (,) (Cokleisli m) where
(***) :: Cokleisli m a1 b1 -> Cokleisli m a2 b2 -> Cokleisli m (a1, a2) (b1, b2)
(Cokleisli (m a1 -> b1
mf1 :: m a1 -> b1)) *** :: Cokleisli m a1 b1
-> Cokleisli m a2 b2 -> Cokleisli m (a1, a2) (b1, b2)
*** (Cokleisli (m a2 -> b2
mf2 :: m a2 -> b2)) = (m (a1, a2) -> (b1, b2)) -> Cokleisli m (a1, a2) (b1, b2)
forall k (w :: k -> *) (a :: k) b. (w a -> b) -> Cokleisli w a b
Cokleisli m (a1, a2) -> (b1, b2)
mf12
where
mf12 :: m (a1, a2) -> (b1, b2)
mf12 :: m (a1, a2) -> (b1, b2)
mf12 m (a1, a2)
x12 = (m a1 -> b1
mf1 (m a1 -> b1) -> m a1 -> b1
forall a b. (a -> b) -> a -> b
$ ((a1, a2) -> a1) -> m (a1, a2) -> m a1
forall (w :: * -> *) a b. Comonad w => (a -> b) -> w a -> w b
liftW (a1, a2) -> a1
forall a b. (a, b) -> a
fst m (a1, a2)
x12, m a2 -> b2
mf2 (m a2 -> b2) -> m a2 -> b2
forall a b. (a -> b) -> a -> b
$ ((a1, a2) -> a2) -> m (a1, a2) -> m a2
forall (w :: * -> *) a b. Comonad w => (a -> b) -> w a -> w b
liftW (a1, a2) -> a2
forall a b. (a, b) -> b
snd m (a1, a2)
x12)
instance forall m. Monad m => CatBiFunctor Either (Kleisli m) where
(***) :: Kleisli m a1 b1 -> Kleisli m a2 b2 -> Kleisli m (Either a1 a2) (Either b1 b2)
(Kleisli (a1 -> m b1
mf1 :: a1 -> m b1)) *** :: Kleisli m a1 b1
-> Kleisli m a2 b2 -> Kleisli m (Either a1 a2) (Either b1 b2)
*** (Kleisli (a2 -> m b2
mf2 :: a2 -> m b2)) = (Either a1 a2 -> m (Either b1 b2))
-> Kleisli m (Either a1 a2) (Either b1 b2)
forall (m :: * -> *) a b. (a -> m b) -> Kleisli m a b
Kleisli Either a1 a2 -> m (Either b1 b2)
mf12
where
mf12 :: Either a1 a2 -> m (Either b1 b2)
mf12 :: Either a1 a2 -> m (Either b1 b2)
mf12 Either a1 a2
x12 = case Either a1 a2
x12 of
Left a1
x1 -> (b1 -> Either b1 b2) -> m b1 -> m (Either b1 b2)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap b1 -> Either b1 b2
forall a b. a -> Either a b
Left (a1 -> m b1
mf1 a1
x1)
Right a2
x2 -> (b2 -> Either b1 b2) -> m b2 -> m (Either b1 b2)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap b2 -> Either b1 b2
forall a b. b -> Either a b
Right (a2 -> m b2
mf2 a2
x2)