module Fresnel.Bifunctor.Contravariant
( -- * Bicontravariant functors
  Bicontravariant(..)
, contrafirst
, contrasecond
  -- * Phantom parameters
, rphantom
, biphantom
) where

import Data.Bifunctor (Bifunctor(..))
import Data.Profunctor (Forget(..), Profunctor(..), Star(..))
import Data.Functor.Contravariant
import Control.Arrow

-- Bicontravariant functors

class Bicontravariant p where
  contrabimap :: (a' -> a) -> (b' -> b) -> p a b -> p a' b'

instance Bicontravariant (Forget r) where
  contrabimap :: forall a' a b' b.
(a' -> a) -> (b' -> b) -> Forget r a b -> Forget r a' b'
contrabimap a' -> a
f b' -> b
_ = (a' -> r) -> Forget r a' b'
forall {k} r a (b :: k). (a -> r) -> Forget r a b
Forget ((a' -> r) -> Forget r a' b')
-> (Forget r a b -> a' -> r) -> Forget r a b -> Forget r a' b'
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a' -> a) -> (a -> r) -> a' -> r
forall (p :: * -> * -> *) a b c.
Profunctor p =>
(a -> b) -> p b c -> p a c
lmap a' -> a
f ((a -> r) -> a' -> r)
-> (Forget r a b -> a -> r) -> Forget r a b -> a' -> r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Forget r a b -> a -> r
forall {k} r a (b :: k). Forget r a b -> a -> r
runForget

instance Contravariant f => Bicontravariant (Star f) where
  contrabimap :: forall a' a b' b.
(a' -> a) -> (b' -> b) -> Star f a b -> Star f a' b'
contrabimap a' -> a
f b' -> b
g = (a' -> f b') -> Star f a' b'
forall {k} (f :: k -> *) d (c :: k). (d -> f c) -> Star f d c
Star ((a' -> f b') -> Star f a' b')
-> (Star f a b -> a' -> f b') -> Star f a b -> Star f a' b'
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a' -> a) -> (f b -> f b') -> (a -> f b) -> a' -> f b'
forall (p :: * -> * -> *) a b c d.
Profunctor p =>
(a -> b) -> (c -> d) -> p b c -> p a d
dimap a' -> a
f ((b' -> b) -> f b -> f b'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap b' -> b
g) ((a -> f b) -> a' -> f b')
-> (Star f a b -> a -> f b) -> Star f a b -> a' -> f b'
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Star f a b -> a -> f b
forall {k} (f :: k -> *) d (c :: k). Star f d c -> d -> f c
runStar

instance Contravariant m => Bicontravariant (Kleisli m) where
  contrabimap :: forall a' a b' b.
(a' -> a) -> (b' -> b) -> Kleisli m a b -> Kleisli m a' b'
contrabimap a' -> a
f b' -> b
g = (a' -> m b') -> Kleisli m a' b'
forall (m :: * -> *) a b. (a -> m b) -> Kleisli m a b
Kleisli ((a' -> m b') -> Kleisli m a' b')
-> (Kleisli m a b -> a' -> m b')
-> Kleisli m a b
-> Kleisli m a' b'
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a' -> a) -> (m b -> m b') -> (a -> m b) -> a' -> m b'
forall (p :: * -> * -> *) a b c d.
Profunctor p =>
(a -> b) -> (c -> d) -> p b c -> p a d
dimap a' -> a
f ((b' -> b) -> m b -> m b'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap b' -> b
g) ((a -> m b) -> a' -> m b')
-> (Kleisli m a b -> a -> m b) -> Kleisli m a b -> a' -> m b'
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Kleisli m a b -> a -> m b
forall (m :: * -> *) a b. Kleisli m a b -> a -> m b
runKleisli


contrafirst :: Bicontravariant p => (a' -> a) -> p a b -> p a' b
contrafirst :: forall (p :: * -> * -> *) a' a b.
Bicontravariant p =>
(a' -> a) -> p a b -> p a' b
contrafirst = ((a' -> a) -> (b -> b) -> p a b -> p a' b
forall (p :: * -> * -> *) a' a b' b.
Bicontravariant p =>
(a' -> a) -> (b' -> b) -> p a b -> p a' b'
`contrabimap` b -> b
forall a. a -> a
id)

contrasecond :: Bicontravariant p => (b' -> b) -> p a b -> p a b'
contrasecond :: forall (p :: * -> * -> *) b' b a.
Bicontravariant p =>
(b' -> b) -> p a b -> p a b'
contrasecond = (a -> a
forall a. a -> a
id (a -> a) -> (b' -> b) -> p a b -> p a b'
forall (p :: * -> * -> *) a' a b' b.
Bicontravariant p =>
(a' -> a) -> (b' -> b) -> p a b -> p a' b'
`contrabimap`)


-- Phantom parameters

rphantom :: (Profunctor p, Bicontravariant p) => p a b -> p a c
rphantom :: forall (p :: * -> * -> *) a b c.
(Profunctor p, Bicontravariant p) =>
p a b -> p a c
rphantom = (c -> ()) -> p a () -> p a c
forall (p :: * -> * -> *) b' b a.
Bicontravariant p =>
(b' -> b) -> p a b -> p a b'
contrasecond (() -> c -> ()
forall a b. a -> b -> a
const ()) (p a () -> p a c) -> (p a b -> p a ()) -> p a b -> p a c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (b -> ()) -> p a b -> p a ()
forall (p :: * -> * -> *) b c a.
Profunctor p =>
(b -> c) -> p a b -> p a c
rmap (() -> b -> ()
forall a b. a -> b -> a
const ())


biphantom :: (Bifunctor p, Bicontravariant p) => p a b -> p c d
biphantom :: forall (p :: * -> * -> *) a b c d.
(Bifunctor p, Bicontravariant p) =>
p a b -> p c d
biphantom = (c -> ()) -> (d -> ()) -> p () () -> p c d
forall (p :: * -> * -> *) a' a b' b.
Bicontravariant p =>
(a' -> a) -> (b' -> b) -> p a b -> p a' b'
contrabimap (() -> c -> ()
forall a b. a -> b -> a
const ()) (() -> d -> ()
forall a b. a -> b -> a
const ()) (p () () -> p c d) -> (p a b -> p () ()) -> p a b -> p c d
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> ()) -> (b -> ()) -> p a b -> p () ()
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (() -> a -> ()
forall a b. a -> b -> a
const ()) (() -> b -> ()
forall a b. a -> b -> a
const ())