module Data.Functor.Composition.TT (TT (..)) where

import "morphisms" Control.Morphism ((.), ($))

import Control.Functor.Covariant (Covariant ((<$>), comap))
import Control.Functor.Covariant.Extractable (Extractable (extract))
import Control.Functor.Covariant.Exclusive (Exclusive (exclusive))
import Control.Functor.Covariant.Pointable (Pointable (point))
import Control.Functor.Covariant.Alternative (Alternative ((<+>)))
import Control.Functor.Covariant.Applicative (Applicative ((<*>), apply))
import Control.Functor.Covariant.Composition.Adjoint (Adjoint (phi, psi))
import Control.Functor.Contravariant (Contravariant ((>$<), contramap))
import Control.Variance (Variant (Co, Contra))

newtype TT ct cu cv t u v a = TT { tt :: t (u (v a)) }

instance (Covariant t, Covariant u, Covariant v) => Covariant (TT Co Co Co t u v) where
	f <$> TT x = TT $ (comap . comap . comap) f x

instance (Covariant t, Covariant u, Contravariant v) => Contravariant (TT Co Co Contra t u v) where
	f >$< TT x = TT $ (comap . comap) (contramap f) x

instance (Covariant t, Contravariant u, Covariant v) => Contravariant (TT Co Contra Co t u v) where
	f >$< TT x = TT $ contramap (comap f) <$> x

instance (Contravariant t, Covariant u, Covariant v) => Contravariant (TT Contra Co Co t u v) where
	f >$< TT x = TT $ comap (comap f) >$< x

instance (Contravariant t, Contravariant u, Covariant v) => Covariant (TT Contra Contra Co t u v) where
	f <$> TT x = TT $ contramap (comap f) >$< x

instance (Covariant t, Contravariant u, Contravariant v) => Covariant (TT Co Contra Contra t u v) where
	f <$> TT x = TT $ contramap (contramap f) <$> x

instance (Contravariant t, Covariant u, Contravariant v) => Covariant (TT Contra Co Contra t u v) where
	f <$> TT x = TT $ comap (contramap f) >$< x

instance (Contravariant t, Contravariant u, Contravariant v) => Contravariant (TT Contra Contra Contra t u v) where
	f >$< TT x = TT $ (contramap . contramap . contramap) f x

instance (Applicative t, Applicative u, Applicative v) => Applicative (TT Co Co Co t u v) where
	TT f <*> TT x = TT $ (comap apply . (comap . comap) apply $ f) <*> x

instance (Alternative t, Covariant u, Covariant v) => Alternative (TT Co Co Co t u v) where
	TT x <+> TT y = TT $ x <+> y

instance (Exclusive t, Covariant u, Covariant v) => Exclusive (TT Co Co Co t u v) where
	exclusive = TT exclusive

instance (Pointable t, Pointable u, Pointable v) => Pointable (TT Co Co Co t u v) where
	point = TT . point . point . point

instance (Extractable t, Extractable u, Extractable v) => Extractable (TT Co Co Co t u v) where
	extract = extract . extract . extract . tt

type Adjunctive t u = (Extractable t, Pointable t, Extractable u, Pointable u, Adjoint t u)

instance (Adjunctive t w, Adjunctive v x, Adjunctive u y) => Adjoint (TT Co Co Co t v u) (TT Co Co Co w x y) where
	phi f = point . f . point
	psi f = extract . extract . comap f