module Data.Functor.Yoneda (Yoneda (..)) where

import "morphisms" Control.Morphism ((.), ($), constant, identity, flip)

import Control.Functor.Covariant (Covariant ((<$>), comap))
import Control.Functor.Covariant.Applicative (Applicative ((<*>)))
import Control.Functor.Covariant.Alternative (Alternative ((<+>)))
import Control.Functor.Covariant.Exclusive (Exclusive (exclusive))
import Control.Functor.Covariant.Extractable (Extractable (extract))
import Control.Functor.Covariant.Pointable (Pointable (point))
import Control.Functor.Covariant.Composition.Traversable (Traversable ((->>), traverse))
import Control.Functor.Covariant.Composition.Distributive (Distributive ((>>-), collect))
import Control.Functor.Covariant.Composition.Adjoint (Adjoint (phi, psi))
import Control.Functor.Covariant.Composition.Bindable (Bindable ((>>=)))
import Control.Functor.Covariant.Composition.Extendable (Extendable ((=>>), extend))
import Control.Functor.Covariant.Transformation.Liftable (Liftable (lift))
import Control.Functor.Covariant.Transformation.Lowerable (Lowerable (lower))

newtype Yoneda (t :: * -> *) (a :: *) = Yoneda
	{ yoneda :: forall b . (a -> b) -> t b }

instance Covariant (Yoneda t) where
	f <$> x = Yoneda (\k -> yoneda x (k . f))

instance Applicative t => Applicative (Yoneda t) where
	Yoneda f <*> Yoneda x = Yoneda (\g -> f (g .) <*> x identity)

instance Alternative t => Alternative (Yoneda t) where
	Yoneda f <+> Yoneda g = Yoneda (\k -> f k <+> g k)

instance Exclusive t => Exclusive (Yoneda t) where
	exclusive = Yoneda (constant exclusive)

instance Pointable t => Pointable (Yoneda t) where
	point x = Yoneda (\f -> point $ f x)

instance Extractable t => Extractable (Yoneda t) where
	extract (Yoneda f) = extract $ f identity

instance Liftable Yoneda where
	lift x = Yoneda (\f -> f <$> x)

instance Lowerable Yoneda where
	lower (Yoneda f) = f identity

instance Traversable t => Traversable (Yoneda t) where
	x ->> f = comap lift . traverse f . lower $ x

instance Distributive t => Distributive (Yoneda t) where
	x >>- f = lift . collect (lower . f) $ x

instance (Extractable t, Pointable t, Extractable u, Pointable u) => Adjoint (Yoneda t) (Yoneda u) where
	phi f = point . f . point
	psi f = extract . extract . comap f

instance Bindable t => Bindable (Yoneda t) where
	Yoneda f >>= g = Yoneda (\k -> f identity >>= flip yoneda k . g)

instance Extendable t => Extendable (Yoneda t) where
	Yoneda f =>> g = Yoneda (\k -> extend (k . g . lift) (f identity))