{-# LANGUAGE ImpredicativeTypes #-}
{-# OPTIONS_GHC -Wno-orphans #-}

-- | Two Parameter Functors of arbitrary categories.
module Kindly.Bifunctor
  ( Bifunctor,
    bimap,
    lmap,
    rmap,
  )
where

--------------------------------------------------------------------------------

import Control.Category
import Data.Bifunctor qualified as Hask
import Data.Either (Either)
import Data.Function (flip)
import Data.Functor qualified as Hask
import Data.Functor.Const (Const)
import Data.Functor.Contravariant (Op (..))
import Data.Kind (Constraint, Type)
import Data.Profunctor qualified as Hask
import Data.Semigroup qualified as Semigroup
import Data.These (These)
import GHC.Generics (K1)
import Kindly.Class
import Kindly.Functor ()

--------------------------------------------------------------------------------

-- | A 'CategoricalFunctor' of kind @Type -> Type@ mapping from an
-- arbitrary category @cat1@ to a functor category @cat2 ~> (->)@.
type Bifunctor :: (Type -> Type -> Type) -> (Type -> Type -> Type) -> (Type -> Type -> Type) -> Constraint
type Bifunctor cat1 cat2 p = (MapArg2 cat1 cat2 p, forall x. MapArg1 cat2 (p x))

-- | Lift a morphism @cat1 a a'@ and a morphism @cat2 b b'@ into a
-- function @p a b -> p a' b'@.
bimap :: forall cat1 cat2 p. (Bifunctor cat1 cat2 p) => forall a b a' b'. (a `cat1` a') -> (b `cat2` b') -> p a b -> p a' b'
bimap :: forall (cat1 :: * -> * -> *) (cat2 :: * -> * -> *)
       (p :: * -> * -> *) a b a' b'.
Bifunctor cat1 cat2 p =>
cat1 a a' -> cat2 b b' -> p a b -> p a' b'
bimap cat1 a a'
f cat2 b b'
g = cat1 a a' -> forall x. p a x -> p a' x
forall a b. cat1 a b -> forall x. p a x -> p b x
forall {from} {s} (cat1 :: Cat from) (cat2 :: Cat s)
       (p :: from -> s -> *) (a :: from) (b :: from).
MapArg2 cat1 cat2 p =>
cat1 a b -> forall (x :: s). p a x -> p b x
map2 cat1 a a'
f (p a b' -> p a' b') -> (p a b -> p a b') -> p a b -> p a' b'
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. cat2 b b' -> p a b -> p a b'
forall a b. cat2 a b -> p a a -> p a b
forall {from} (cat1 :: Cat from) (p :: from -> *) (a :: from)
       (b :: from).
MapArg1 cat1 p =>
cat1 a b -> p a -> p b
map1 cat2 b b'
g

-- | Lift a morphism @cat1 a b@ into a function @p a x -> p b x@.
lmap :: (Category cat2, Bifunctor cat1 cat2 p) => (a `cat1` b) -> p a x -> p b x
lmap :: forall (cat2 :: * -> * -> *) (cat1 :: * -> * -> *)
       (p :: * -> * -> *) a b x.
(Category cat2, Bifunctor cat1 cat2 p) =>
cat1 a b -> p a x -> p b x
lmap = (cat1 a b -> cat2 x x -> p a x -> p b x)
-> cat2 x x -> cat1 a b -> p a x -> p b x
forall a b c. (a -> b -> c) -> b -> a -> c
flip cat1 a b -> cat2 x x -> p a x -> p b x
forall a b a' b'. cat1 a a' -> cat2 b b' -> p a b -> p a' b'
forall (cat1 :: * -> * -> *) (cat2 :: * -> * -> *)
       (p :: * -> * -> *) a b a' b'.
Bifunctor cat1 cat2 p =>
cat1 a a' -> cat2 b b' -> p a b -> p a' b'
bimap cat2 x x
forall a. cat2 a a
forall {k} (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id

-- | Lift a morphism @cat2 a b@ into a function @p x a -> p x b@.
rmap :: (Bifunctor cat1 cat2 p) => (a `cat2` b) -> p x a -> p x b
rmap :: forall (cat1 :: * -> * -> *) (cat2 :: * -> * -> *)
       (p :: * -> * -> *) a b x.
Bifunctor cat1 cat2 p =>
cat2 a b -> p x a -> p x b
rmap = cat1 x x -> cat2 a b -> p x a -> p x b
forall a b a' b'. cat1 a a' -> cat2 b b' -> p a b -> p a' b'
forall (cat1 :: * -> * -> *) (cat2 :: * -> * -> *)
       (p :: * -> * -> *) a b a' b'.
Bifunctor cat1 cat2 p =>
cat1 a a' -> cat2 b b' -> p a b -> p a' b'
bimap cat1 x x
forall a. cat1 a a
forall {k} (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id

--------------------------------------------------------------------------------

newtype FromBifunctor f a b = FromBifunctor (f a b)
  deriving newtype ((forall a b.
 (a -> b) -> FromBifunctor f a a -> FromBifunctor f a b)
-> (forall a b. a -> FromBifunctor f a b -> FromBifunctor f a a)
-> Functor (FromBifunctor f a)
forall a b. a -> FromBifunctor f a b -> FromBifunctor f a a
forall a b. (a -> b) -> FromBifunctor f a a -> FromBifunctor f a b
forall k (f :: k -> * -> *) (a :: k) a b.
Functor (f a) =>
a -> FromBifunctor f a b -> FromBifunctor f a a
forall k (f :: k -> * -> *) (a :: k) a b.
Functor (f a) =>
(a -> b) -> FromBifunctor f a a -> FromBifunctor f a b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall k (f :: k -> * -> *) (a :: k) a b.
Functor (f a) =>
(a -> b) -> FromBifunctor f a a -> FromBifunctor f a b
fmap :: forall a b. (a -> b) -> FromBifunctor f a a -> FromBifunctor f a b
$c<$ :: forall k (f :: k -> * -> *) (a :: k) a b.
Functor (f a) =>
a -> FromBifunctor f a b -> FromBifunctor f a a
<$ :: forall a b. a -> FromBifunctor f a b -> FromBifunctor f a a
Hask.Functor, (forall a. Functor (FromBifunctor f a)) =>
(forall a b c d.
 (a -> b) -> (c -> d) -> FromBifunctor f a c -> FromBifunctor f b d)
-> (forall a b c.
    (a -> b) -> FromBifunctor f a c -> FromBifunctor f b c)
-> (forall b c a.
    (b -> c) -> FromBifunctor f a b -> FromBifunctor f a c)
-> Bifunctor (FromBifunctor f)
forall a. Functor (FromBifunctor f a)
forall a b c.
(a -> b) -> FromBifunctor f a c -> FromBifunctor f b c
forall b c a.
(b -> c) -> FromBifunctor f a b -> FromBifunctor f a c
forall a b c d.
(a -> b) -> (c -> d) -> FromBifunctor f a c -> FromBifunctor f b d
forall (f :: * -> * -> *) a.
Bifunctor f =>
Functor (FromBifunctor f a)
forall (f :: * -> * -> *) a b c.
Bifunctor f =>
(a -> b) -> FromBifunctor f a c -> FromBifunctor f b c
forall (f :: * -> * -> *) b c a.
Bifunctor f =>
(b -> c) -> FromBifunctor f a b -> FromBifunctor f a c
forall (f :: * -> * -> *) a b c d.
Bifunctor f =>
(a -> b) -> (c -> d) -> FromBifunctor f a c -> FromBifunctor f b d
forall (p :: * -> * -> *).
(forall a. Functor (p a)) =>
(forall a b c d. (a -> b) -> (c -> d) -> p a c -> p b d)
-> (forall a b c. (a -> b) -> p a c -> p b c)
-> (forall b c a. (b -> c) -> p a b -> p a c)
-> Bifunctor p
$cbimap :: forall (f :: * -> * -> *) a b c d.
Bifunctor f =>
(a -> b) -> (c -> d) -> FromBifunctor f a c -> FromBifunctor f b d
bimap :: forall a b c d.
(a -> b) -> (c -> d) -> FromBifunctor f a c -> FromBifunctor f b d
$cfirst :: forall (f :: * -> * -> *) a b c.
Bifunctor f =>
(a -> b) -> FromBifunctor f a c -> FromBifunctor f b c
first :: forall a b c.
(a -> b) -> FromBifunctor f a c -> FromBifunctor f b c
$csecond :: forall (f :: * -> * -> *) b c a.
Bifunctor f =>
(b -> c) -> FromBifunctor f a b -> FromBifunctor f a c
second :: forall b c a.
(b -> c) -> FromBifunctor f a b -> FromBifunctor f a c
Hask.Bifunctor)

instance (Hask.Bifunctor p, FunctorOf (->) (->) (p x)) => CategoricalFunctor (FromBifunctor p x) where
  type Dom (FromBifunctor p x) = (->)
  type Cod (FromBifunctor p x) = (->)

  map :: (a -> b) -> FromBifunctor p x a -> FromBifunctor p x b
  map :: forall a b. (a -> b) -> FromBifunctor p x a -> FromBifunctor p x b
map a -> b
f (FromBifunctor p x a
pab) = p x b -> FromBifunctor p x b
forall {k} {k} (f :: k -> k -> *) (a :: k) (b :: k).
f a b -> FromBifunctor f a b
FromBifunctor (Dom (p x) a b -> Cod (p x) (p x a) (p x b)
forall a b. Dom (p x) a b -> Cod (p x) (p x a) (p x b)
forall from to (f :: from -> to) (a :: from) (b :: from).
CategoricalFunctor f =>
Dom f a b -> Cod f (f a) (f b)
map Dom (p x) a b
a -> b
f p x a
pab)

instance (Hask.Bifunctor p, forall x. FunctorOf (->) (->) (p x)) => CategoricalFunctor (FromBifunctor p) where
  type Dom (FromBifunctor p) = (->)
  type Cod (FromBifunctor p) = (->) ~> (->)

  map :: (a -> b) -> ((->) ~> (->)) (FromBifunctor p a) (FromBifunctor p b)
  map :: forall a b.
(a -> b) -> (~>) (->) (->) (FromBifunctor p a) (FromBifunctor p b)
map a -> b
f = (forall x. FromBifunctor p a x -> FromBifunctor p b x)
-> Nat (->) (->) (FromBifunctor p a) (FromBifunctor p b)
forall {t} {s} (target :: Cat t) (f :: s -> t) (g :: s -> t)
       (source :: Cat s).
(forall (x :: s). target (f x) (g x)) -> Nat source target f g
Nat (\(FromBifunctor p a x
pax) -> p b x -> FromBifunctor p b x
forall {k} {k} (f :: k -> k -> *) (a :: k) (b :: k).
f a b -> FromBifunctor f a b
FromBifunctor ((a -> b) -> p a x -> p b x
forall a b c. (a -> b) -> p a c -> p b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
Hask.first a -> b
f p a x
pax))

--------------------------------------------------------------------------------
-- Covariant (Bi)Functor instances

deriving via (FromBifunctor (,)) instance CategoricalFunctor (,)

deriving via (FromBifunctor ((,,) a)) instance CategoricalFunctor ((,,) a)

deriving via (FromBifunctor ((,,,) a b)) instance CategoricalFunctor ((,,,) a b)

deriving via (FromBifunctor ((,,,,) a b c)) instance CategoricalFunctor ((,,,,) a b c)

deriving via (FromBifunctor ((,,,,,) a b c d)) instance CategoricalFunctor ((,,,,,) a b c d)

deriving via (FromBifunctor ((,,,,,,) a b c d e)) instance CategoricalFunctor ((,,,,,,) a b c d e)

deriving via (FromBifunctor Either) instance CategoricalFunctor Either

deriving via (FromBifunctor These) instance CategoricalFunctor These

deriving via (FromBifunctor Semigroup.Arg) instance CategoricalFunctor Semigroup.Arg

deriving via (FromBifunctor (Const :: Type -> Type -> Type)) instance CategoricalFunctor (Const :: Type -> Type -> Type)

deriving via (FromBifunctor (K1 i :: Type -> Type -> Type)) instance CategoricalFunctor (K1 i :: Type -> Type -> Type)

--------------------------------------------------------------------------------
-- Covariant MapArg2 instances

instance MapArg2 (->) (->) (,)

instance MapArg2 (->) (->) ((,,) a)

instance MapArg2 (->) (->) ((,,,) a b)

instance MapArg2 (->) (->) ((,,,,) a b c)

instance MapArg2 (->) (->) ((,,,,,) a b c d)

instance MapArg2 (->) (->) ((,,,,,,) a b c d e)

instance MapArg2 (->) (->) Either

-- instance MapArg2 (->) (->) These

instance MapArg2 (->) (->) Semigroup.Arg

instance MapArg2 (->) (->) (Const :: Type -> Type -> Type)

instance MapArg2 (->) (->) (K1 i :: Type -> Type -> Type)

--------------------------------------------------------------------------------

newtype FromProfunctor f a b = FromProfunctor (f a b)
  deriving newtype ((forall a b.
 (a -> b) -> FromProfunctor f a a -> FromProfunctor f a b)
-> (forall a b. a -> FromProfunctor f a b -> FromProfunctor f a a)
-> Functor (FromProfunctor f a)
forall a b. a -> FromProfunctor f a b -> FromProfunctor f a a
forall a b.
(a -> b) -> FromProfunctor f a a -> FromProfunctor f a b
forall k (f :: k -> * -> *) (a :: k) a b.
Functor (f a) =>
a -> FromProfunctor f a b -> FromProfunctor f a a
forall k (f :: k -> * -> *) (a :: k) a b.
Functor (f a) =>
(a -> b) -> FromProfunctor f a a -> FromProfunctor f a b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall k (f :: k -> * -> *) (a :: k) a b.
Functor (f a) =>
(a -> b) -> FromProfunctor f a a -> FromProfunctor f a b
fmap :: forall a b.
(a -> b) -> FromProfunctor f a a -> FromProfunctor f a b
$c<$ :: forall k (f :: k -> * -> *) (a :: k) a b.
Functor (f a) =>
a -> FromProfunctor f a b -> FromProfunctor f a a
<$ :: forall a b. a -> FromProfunctor f a b -> FromProfunctor f a a
Hask.Functor, (forall a b c d.
 (a -> b)
 -> (c -> d) -> FromProfunctor f b c -> FromProfunctor f a d)
-> (forall a b c.
    (a -> b) -> FromProfunctor f b c -> FromProfunctor f a c)
-> (forall b c a.
    (b -> c) -> FromProfunctor f a b -> FromProfunctor f a c)
-> (forall a b c (q :: * -> * -> *).
    Coercible c b =>
    q b c -> FromProfunctor f a b -> FromProfunctor f a c)
-> (forall a b c (q :: * -> * -> *).
    Coercible b a =>
    FromProfunctor f b c -> q a b -> FromProfunctor f a c)
-> Profunctor (FromProfunctor f)
forall a b c.
(a -> b) -> FromProfunctor f b c -> FromProfunctor f a c
forall b c a.
(b -> c) -> FromProfunctor f a b -> FromProfunctor f a c
forall a b c d.
(a -> b)
-> (c -> d) -> FromProfunctor f b c -> FromProfunctor f a d
forall a b c (q :: * -> * -> *).
Coercible b a =>
FromProfunctor f b c -> q a b -> FromProfunctor f a c
forall a b c (q :: * -> * -> *).
Coercible c b =>
q b c -> FromProfunctor f a b -> FromProfunctor f a c
forall (f :: * -> * -> *) a b c.
Profunctor f =>
(a -> b) -> FromProfunctor f b c -> FromProfunctor f a c
forall (f :: * -> * -> *) b c a.
Profunctor f =>
(b -> c) -> FromProfunctor f a b -> FromProfunctor f a c
forall (f :: * -> * -> *) a b c d.
Profunctor f =>
(a -> b)
-> (c -> d) -> FromProfunctor f b c -> FromProfunctor f a d
forall (f :: * -> * -> *) a b c (q :: * -> * -> *).
(Profunctor f, Coercible b a) =>
FromProfunctor f b c -> q a b -> FromProfunctor f a c
forall (f :: * -> * -> *) a b c (q :: * -> * -> *).
(Profunctor f, Coercible c b) =>
q b c -> FromProfunctor f a b -> FromProfunctor f a c
forall (p :: * -> * -> *).
(forall a b c d. (a -> b) -> (c -> d) -> p b c -> p a d)
-> (forall a b c. (a -> b) -> p b c -> p a c)
-> (forall b c a. (b -> c) -> p a b -> p a c)
-> (forall a b c (q :: * -> * -> *).
    Coercible c b =>
    q b c -> p a b -> p a c)
-> (forall a b c (q :: * -> * -> *).
    Coercible b a =>
    p b c -> q a b -> p a c)
-> Profunctor p
$cdimap :: forall (f :: * -> * -> *) a b c d.
Profunctor f =>
(a -> b)
-> (c -> d) -> FromProfunctor f b c -> FromProfunctor f a d
dimap :: forall a b c d.
(a -> b)
-> (c -> d) -> FromProfunctor f b c -> FromProfunctor f a d
$clmap :: forall (f :: * -> * -> *) a b c.
Profunctor f =>
(a -> b) -> FromProfunctor f b c -> FromProfunctor f a c
lmap :: forall a b c.
(a -> b) -> FromProfunctor f b c -> FromProfunctor f a c
$crmap :: forall (f :: * -> * -> *) b c a.
Profunctor f =>
(b -> c) -> FromProfunctor f a b -> FromProfunctor f a c
rmap :: forall b c a.
(b -> c) -> FromProfunctor f a b -> FromProfunctor f a c
$c#. :: forall (f :: * -> * -> *) a b c (q :: * -> * -> *).
(Profunctor f, Coercible c b) =>
q b c -> FromProfunctor f a b -> FromProfunctor f a c
#. :: forall a b c (q :: * -> * -> *).
Coercible c b =>
q b c -> FromProfunctor f a b -> FromProfunctor f a c
$c.# :: forall (f :: * -> * -> *) a b c (q :: * -> * -> *).
(Profunctor f, Coercible b a) =>
FromProfunctor f b c -> q a b -> FromProfunctor f a c
.# :: forall a b c (q :: * -> * -> *).
Coercible b a =>
FromProfunctor f b c -> q a b -> FromProfunctor f a c
Hask.Profunctor)

instance (Hask.Profunctor p, FunctorOf (->) (->) (p x)) => CategoricalFunctor (FromProfunctor p x) where
  type Dom (FromProfunctor p x) = (->)
  type Cod (FromProfunctor p x) = (->)

  map :: (a -> b) -> Cod (FromProfunctor p x) (FromProfunctor p x a) (FromProfunctor p x b)
  map :: forall a b.
(a -> b)
-> Cod
     (FromProfunctor p x) (FromProfunctor p x a) (FromProfunctor p x b)
map a -> b
f (FromProfunctor p x a
pxa) = p x b -> FromProfunctor p x b
forall {k} {k} (f :: k -> k -> *) (a :: k) (b :: k).
f a b -> FromProfunctor f a b
FromProfunctor (Dom (p x) a b -> Cod (p x) (p x a) (p x b)
forall a b. Dom (p x) a b -> Cod (p x) (p x a) (p x b)
forall from to (f :: from -> to) (a :: from) (b :: from).
CategoricalFunctor f =>
Dom f a b -> Cod f (f a) (f b)
map Dom (p x) a b
a -> b
f p x a
pxa)

instance (Hask.Profunctor p) => CategoricalFunctor (FromProfunctor p) where
  type Dom (FromProfunctor p) = Op
  type Cod (FromProfunctor p) = (->) ~> (->)

  map :: Op a b -> ((->) ~> (->)) ((FromProfunctor p) a) ((FromProfunctor p) b)
  map :: forall a b.
Op a b -> (~>) (->) (->) (FromProfunctor p a) (FromProfunctor p b)
map (Op b -> a
f) = (forall x. FromProfunctor p a x -> FromProfunctor p b x)
-> Nat (->) (->) (FromProfunctor p a) (FromProfunctor p b)
forall {t} {s} (target :: Cat t) (f :: s -> t) (g :: s -> t)
       (source :: Cat s).
(forall (x :: s). target (f x) (g x)) -> Nat source target f g
Nat (\(FromProfunctor p a x
pax) -> p b x -> FromProfunctor p b x
forall {k} {k} (f :: k -> k -> *) (a :: k) (b :: k).
f a b -> FromProfunctor f a b
FromProfunctor ((b -> a) -> p a x -> p b x
forall a b c. (a -> b) -> p b c -> p a c
forall (p :: * -> * -> *) a b c.
Profunctor p =>
(a -> b) -> p b c -> p a c
Hask.lmap b -> a
f p a x
pax))

--------------------------------------------------------------------------------
-- Profunctorial Functor instances

deriving via (FromProfunctor (->)) instance CategoricalFunctor (->)

-- TODO: Add remaining Profunctor instances

--------------------------------------------------------------------------------
-- Profunctorial MapArg2 instances

instance MapArg2 Op (->) (->)

-- TODO: Add remaining Profunctor instances