Contravariant.hs

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 f _ = Forget . lmap f . runForget

instance Contravariant f => Bicontravariant (Star f) where
  contrabimap f g = Star . dimap f (contramap g) . runStar

instance Contravariant m => Bicontravariant (Kleisli m) where
  contrabimap f g = Kleisli . dimap f (contramap g) . runKleisli


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

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


-- Phantom parameters

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


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