Backwards.hs

module Pandora.Paradigm.Primary.Transformer.Backwards where

import Pandora.Pattern.Category ((.), ($), (#))
import Pandora.Pattern.Functor.Covariant (Covariant ((<$>)), Covariant_ ((-<$>-)))
import Pandora.Pattern.Functor.Contravariant (Contravariant ((>$<)))
import Pandora.Pattern.Functor.Extractable (Extractable (extract))
import Pandora.Pattern.Functor.Pointable (Pointable (point), Pointable_ (point_))
import Pandora.Pattern.Functor.Applicative (Applicative ((<*>)))
import Pandora.Pattern.Functor.Traversable (Traversable ((->>)))
import Pandora.Pattern.Functor.Distributive (Distributive ((>>-)))
import Pandora.Pattern.Transformer.Liftable (Liftable (lift))
import Pandora.Pattern.Transformer.Lowerable (Lowerable (lower))
import Pandora.Pattern.Transformer.Hoistable (Hoistable ((/|\)))
import Pandora.Paradigm.Primary.Functor.Function ((&))
import Pandora.Paradigm.Controlflow.Effect.Interpreted (Interpreted (Primary, run, unite))

newtype Backwards t a = Backwards (t a)

instance Covariant t => Covariant (Backwards t) where
	f <$> Backwards x = Backwards $ f <$> x

instance Covariant_ t (->) (->) => Covariant_ (Backwards t) (->) (->) where
	f -<$>- Backwards x = Backwards $ f -<$>- x

instance Pointable t (->) => Pointable (Backwards t) (->) where
	point = Backwards . point

instance Pointable_ t (->) => Pointable_ (Backwards t) (->) where
	point_ = Backwards . point_

instance Extractable t (->) => Extractable (Backwards t) (->) where
	extract (Backwards x) = extract x

instance Applicative t => Applicative (Backwards t) where
	Backwards f <*> Backwards x = Backwards # (&) <$> x <*> f

instance Traversable t => Traversable (Backwards t) where
	Backwards x ->> f = Backwards <$> x ->> f

instance Distributive t => Distributive (Backwards t) where
	x >>- f = Backwards $ x >>- run . f

instance Contravariant t => Contravariant (Backwards t) where
	f >$< Backwards x = Backwards $ f >$< x

instance Interpreted (Backwards t) where
	type Primary (Backwards t) a = t a
	run ~(Backwards x) = x
	unite = Backwards

instance Liftable Backwards where
	lift = Backwards

instance Lowerable Backwards where
	lower = run

instance Hoistable Backwards where
	f /|\ Backwards x = Backwards $ f x