{-# LANGUAGE CPP #-}
#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702
{-# LANGUAGE Trustworthy #-}
#endif
{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleContexts #-}
-------------------------------------------------------------------------------------------
-- |
-- Module   : Control.Categorical.Bifunctor
-- Copyright: 2008-2010 Edward Kmett
-- License  : BSD3
--
-- Maintainer : Edward Kmett <ekmett@gmail.com>
-- Stability  : experimental
-- Portability: non-portable (functional-dependencies)
--
-- A more categorical definition of 'Bifunctor'
-------------------------------------------------------------------------------------------
module Control.Categorical.Bifunctor
    ( PFunctor (first)
    , QFunctor (second)
    , Bifunctor (bimap)
    , dimap
    , difirst
    ) where

import Prelude hiding (id, (.))
import Control.Category
import Control.Category.Dual

class (Category r, Category t) => PFunctor p r t | p r -> t, p t -> r where
    first :: r a b -> t (p a c) (p b c)
--    default first :: Bifunctor p r s t => r a b -> t (p a c) (p b c)
--    first f = bimap f id

class (Category s, Category t) => QFunctor q s t | q s -> t, q t -> s where
    second :: s a b -> t (q c a) (q c b)
--    default second :: Bifunctor q r s t => s a b -> t (q c a) (q c b)
--    second = bimap id

-- | Minimal definition: @bimap@ 

-- or both @first@ and @second@
class (PFunctor p r t, QFunctor p s t) => Bifunctor p r s t | p r -> s t, p s -> r t, p t -> r s where
    bimap :: r a b -> s c d -> t (p a c) (p b d)
    -- bimap f g = second g . first f

instance PFunctor (,) (->) (->) where first :: (a -> b) -> (a, c) -> (b, c)
first f :: a -> b
f = (a -> b) -> (c -> c) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) (r :: * -> * -> *) (s :: * -> * -> *)
       (t :: * -> * -> *) a b c d.
Bifunctor p r s t =>
r a b -> s c d -> t (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
instance QFunctor (,) (->) (->) where second :: (a -> b) -> (c, a) -> (c, b)
second = (c -> c) -> (a -> b) -> (c, a) -> (c, b)
forall (p :: * -> * -> *) (r :: * -> * -> *) (s :: * -> * -> *)
       (t :: * -> * -> *) a b c d.
Bifunctor p r s t =>
r a b -> s c d -> t (p a c) (p b d)
bimap c -> c
forall k (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id
instance Bifunctor (,) (->) (->) (->) where
    bimap :: (a -> b) -> (c -> d) -> (a, c) -> (b, d)
bimap f :: a -> b
f g :: c -> d
g (a :: a
a,b :: c
b)= (a -> b
f a
a, c -> d
g c
b)

instance PFunctor Either (->) (->) where first :: (a -> b) -> Either a c -> Either b c
first f :: a -> b
f = (a -> b) -> (c -> c) -> Either a c -> Either b c
forall (p :: * -> * -> *) (r :: * -> * -> *) (s :: * -> * -> *)
       (t :: * -> * -> *) a b c d.
Bifunctor p r s t =>
r a b -> s c d -> t (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
instance QFunctor Either (->) (->) where second :: (a -> b) -> Either c a -> Either c b
second = (c -> c) -> (a -> b) -> Either c a -> Either c b
forall (p :: * -> * -> *) (r :: * -> * -> *) (s :: * -> * -> *)
       (t :: * -> * -> *) a b c d.
Bifunctor p r s t =>
r a b -> s c d -> t (p a c) (p b d)
bimap c -> c
forall k (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id
instance Bifunctor Either (->) (->) (->) where
    bimap :: (a -> b) -> (c -> d) -> Either a c -> Either b d
bimap f :: a -> b
f _ (Left a :: a
a) = b -> Either b d
forall a b. a -> Either a b
Left (a -> b
f a
a)
    bimap _ g :: c -> d
g (Right a :: c
a) = d -> Either b d
forall a b. b -> Either a b
Right (c -> d
g c
a)

instance QFunctor (->) (->) (->) where
    second :: (a -> b) -> (c -> a) -> c -> b
second = (a -> b) -> (c -> a) -> c -> b
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
(.)

difirst :: PFunctor f (Dual s) t => s b a -> t (f a c) (f b c)
difirst :: s b a -> t (f a c) (f b c)
difirst = Dual s a b -> t (f a c) (f b c)
forall (p :: * -> * -> *) (r :: * -> * -> *) (t :: * -> * -> *) a b
       c.
PFunctor p r t =>
r a b -> t (p a c) (p b c)
first (Dual s a b -> t (f a c) (f b c))
-> (s b a -> Dual s a b) -> s b a -> t (f a c) (f b c)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. s b a -> Dual s a b
forall (k :: * -> * -> *) a b. k b a -> Dual k a b
Dual

dimap :: Bifunctor f (Dual s) t u => s b a -> t c d -> u (f a c) (f b d)
dimap :: s b a -> t c d -> u (f a c) (f b d)
dimap = Dual s a b -> t c d -> u (f a c) (f b d)
forall (p :: * -> * -> *) (r :: * -> * -> *) (s :: * -> * -> *)
       (t :: * -> * -> *) a b c d.
Bifunctor p r s t =>
r a b -> s c d -> t (p a c) (p b d)
bimap (Dual s a b -> t c d -> u (f a c) (f b d))
-> (s b a -> Dual s a b) -> s b a -> t c d -> u (f a c) (f b d)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. s b a -> Dual s a b
forall (k :: * -> * -> *) a b. k b a -> Dual k a b
Dual