cofunctor.hs

{-# LANGUAGE ConstraintKinds, TypeApplications, ScopedTypeVariables, FlexibleInstances, RankNTypes, DeriveFunctor #-}
import Data.Functor.Compose
import Data.Functor.Identity

class Cofunctor f where
  comap :: (f a -> f b) -> (a -> b)

instance Cofunctor Identity where
  comap f = runIdentity . f . Identity

instance (Cofunctor f, Cofunctor g) => Cofunctor (Compose f g) where
  comap f = comap (comap (getCompose . f . Compose))

newtype WriterCoT w f a = WriterCoT { runWriterCoT :: (w, f a) } deriving Functor
instance Cofunctor f => Cofunctor (WriterCoT w f) where
  comap f = comap (\fa -> let (w, fb) = runWriterCoT . f . WriterCoT $ (w, fa) in fb)

newtype StateCoT s f a = StateCoT { runStateCoT :: s -> (f a, s) } deriving Functor
instance Cofunctor f => Cofunctor (StateCoT s f) where
  comap f = comap ((\g -> let (fa, s) = g s in fa) . runStateCoT . f . StateCoT . (,))


type Lens f = (Functor f, Cofunctor f)

get :: Cofunctor f => f b -> b
get fb = comap (const fb) ()

set :: Functor f => b -> f a -> f b
set b = fmap (const b)



class Cotraversable t where
  cotraverse :: Applicative f => (t a -> f (t b)) -> (a -> f b)


class Codistributive t where
  cocotraverse :: Functor f => (f (t a) -> t b) -> (f a -> b)

instance Codistributive ((,) x) where
  cocotraverse g fa = let (x, b) = g (((,) x) <$> fa) in b


class Cofunctor f => Coapplicative f where
  copure :: f a -> a
  coliftA2 :: (f a -> f b -> f c) -> a -> b -> c

instance Coapplicative f => Coapplicative (WriterCoT w f) where
  copure (WriterCoT (_, fa)) = copure fa
  coliftA2 f = coliftA2 (\fa fb -> let WriterCoT (w, fc) = f (WriterCoT (w, fa)) (WriterCoT (w, fb)) in fc)

instance Coapplicative f => Coapplicative (StateCoT s f) where
  copure (StateCoT g) = let (fa, s) = g s in copure fa
  coliftA2 f = coliftA2 @f (\fa fb -> let (fc, s) = ($ s) $ runStateCoT $ f (StateCoT . (,) $ fa) (StateCoT . (,) $ fb) in fc)