Profunctors, but in the other direction

Retrofunctor.hs

module Retrofunctor where

import Control.Applicative
import Control.Arrow
import Data.Bifunctor.Biff
import Data.Bifunctor.Clown
import Data.Bifunctor.Flip
import Data.Bifunctor.Joker
import Data.Bifunctor.Product
import Data.Bifunctor.Sum
import Data.Bifunctor.Tannen
import Data.Functor.Constant
import Data.Functor.Contravariant
import Data.Profunctor
import Data.Profunctor.Cayley
import Data.Profunctor.Choice
import Data.Profunctor.Closed
import Data.Profunctor.Composition
import Data.Profunctor.Mapping
import Data.Profunctor.Ran
import Data.Profunctor.Strong
import Data.Profunctor.Traversing
import GHC.Generics

-- | If a 'Profunctor' is contravariant in its first argument and covariant in
-- its second argument, then a 'Retrofunctor' is the other way around:
-- covariant in its first argument and contravariant in its second argument.
--
-- Laws:
--
-- @
-- qimap id id ≡ id
-- qimap (f . g) (h . i) ≡ qimap f i . qimap g h
-- @
class Retrofunctor q where
  -- | Map over both arguments at the same time.
  qimap :: (a -> b) -> (c -> d) -> q a d -> q b c

instance Retrofunctor Op where
  qimap f g op = Op (f . getOp op . g)

instance Retrofunctor Const where
  qimap f _ = Const . f . getConst

instance Retrofunctor Constant where
  qimap f _ = Constant . f . getConstant

instance Retrofunctor (K1 i) where
  qimap f _ = K1 . f . unK1

-- | Orphan instance.
instance Retrofunctor p => Profunctor (Flip p) where
  dimap f g = Flip . qimap g f . runFlip

instance Profunctor q => Retrofunctor (Flip q) where
  qimap f g = Flip . dimap g f . runFlip

instance (Retrofunctor q, Functor f, Functor g) => Retrofunctor (Biff q f g) where
  qimap f g = Biff . qimap (fmap f) (fmap g) . runBiff

instance (Functor f, Retrofunctor p) => Retrofunctor (Cayley f p) where
  qimap f g = Cayley . fmap (qimap f g) . runCayley

instance Retrofunctor p => Retrofunctor (Closure p) where
  qimap f g (Closure p) = Closure $ qimap (fmap f) (fmap g) p

instance Functor f => Retrofunctor (Clown f) where
  qimap f _ = Clown . fmap f . runClown

instance Retrofunctor p => Retrofunctor (Codensity p) where
  qimap ab cd f = Codensity (qimap id cd . runCodensity f . qimap id ab)

instance Retrofunctor p => Retrofunctor (CofreeMapping p) where
  qimap f g (CofreeMapping p) = CofreeMapping $ qimap (fmap f) (fmap g) p

instance Retrofunctor p => Retrofunctor (CofreeTraversing p) where
  qimap f g (CofreeTraversing p) = CofreeTraversing $ qimap (fmap f) (fmap g) p

instance Contravariant f => Retrofunctor (Joker f) where
  qimap _ g = Joker . contramap g . runJoker

instance (Retrofunctor p, Retrofunctor q) => Retrofunctor (Procompose p q) where
  qimap l r (Procompose f g) = Procompose (qimap id r f) (qimap l id g)

instance (Retrofunctor p, Retrofunctor q) => Retrofunctor (Product p q) where
  qimap f g (Pair p q) = Pair (qimap f g p) (qimap f g q)

instance (Retrofunctor p, Retrofunctor q) => Retrofunctor (Ran p q) where
  qimap ab cd f = Ran (qimap id cd . runRan f . qimap id ab)

instance (Retrofunctor p, Retrofunctor q) => Retrofunctor (Rift p q) where
  qimap ab cd f = Rift (qimap ab id . runRift f . qimap cd id)

instance (Retrofunctor p, Retrofunctor q) => Retrofunctor (Sum p q) where
  qimap f g (L2 x) = L2 (qimap f g x)
  qimap f g (R2 y) = R2 (qimap f g y)

instance Retrofunctor p => Retrofunctor (Tambara p) where
  qimap f g (Tambara p) = Tambara $ qimap (first f) (first g) p

instance Retrofunctor p => Retrofunctor (TambaraSum p) where
  qimap f g (TambaraSum p) = TambaraSum $ qimap (left f) (left g) p

instance (Functor f, Retrofunctor q) => Retrofunctor (Tannen f q) where
  qimap f g = Tannen . fmap (qimap f g) . runTannen