Adaptable.hs

{-# LANGUAGE UndecidableInstances #-}

module Pandora.Paradigm.Controlflow.Effect.Adaptable (Adaptable (..)) where

import Pandora.Core.Functor (type (~>))
import Pandora.Pattern.Category (identity, (.))
import Pandora.Pattern.Functor.Covariant (Covariant)
import Pandora.Pattern.Functor.Pointable (Pointable)
import Pandora.Pattern.Functor.Extractable (Extractable)
import Pandora.Pattern.Functor.Traversable (Traversable)
import Pandora.Pattern.Functor.Comonad (Comonad)
import Pandora.Pattern.Functor.Monad (Monad)
import Pandora.Pattern.Transformer (Liftable (lift), Lowerable (lower), Hoistable (hoist))
import Pandora.Paradigm.Controlflow.Effect.Interpreted (Schematic)
import Pandora.Paradigm.Controlflow.Effect.Transformer (Transformer, wrap, bring, (:>), (:<))

class Adaptable t u where
	{-# MINIMAL adapt #-}
	adapt :: t ~> u

type Lifting t u = (Transformer Monad t, Liftable (Schematic Monad t), Traversable u)
type Lowering t u = (Transformer Comonad t, Lowerable (Schematic Comonad t), Covariant u)
type Wrappable t u = (Transformer Monad t, Pointable u)
type Bringable t u = (Transformer Comonad t, Extractable u)

instance Covariant t => Adaptable t t where
	adapt = identity

instance (Covariant (t :> u), Lifting t u) => Adaptable u (t :> u) where
	adapt = lift

instance (Covariant (t :> u), Wrappable t u) => Adaptable t (t :> u) where
	adapt = wrap

instance (Covariant (t :> u), Lowering t u) => Adaptable (t :< u) u where
	adapt = lower

instance (Covariant (t :< u), Bringable t u) => Adaptable (t :< u) t where
	adapt = bring

instance
	( Covariant (t :> u :> v)
	, Liftable (Schematic Monad t)
	, Traversable (Schematic Monad u v)
	, Wrappable u v
	) => Adaptable u (t :> u :> v) where
	adapt = lift . wrap

instance
	( Covariant (t :> u :> v)
	, Lifting t (Schematic Monad u v)
	, Lifting u v
	) => Adaptable v (t :> u :> v) where
	adapt = lift . lift

instance
	( Covariant (t :< u :< v)
	, Lowering t (Schematic Comonad u v)
	, Bringable u v
	) => Adaptable (t :< u :< v) u where
	adapt = bring . lower

instance
	( Covariant (t :< u :< v)
	, Lowering t (Schematic Comonad u v)
	, Lowering u v
	) => Adaptable (t :< u :< v) v where
	adapt = lower . lower

instance
	( Covariant (t :> u :> v :> w)
	, Liftable (Schematic Monad t)
	, Lifting t (Schematic Monad u (v :> w))
	, Lifting u (Schematic Monad v w)
	, Wrappable v w
	) => Adaptable v (t :> u :> v :> w) where
	adapt = lift . lift . wrap

instance
	( Covariant (t :> u :> v :> w)
	, Lifting t (Schematic Monad u v)
	, Lifting t (Schematic Monad u (v :> w))
	, Lifting u (Schematic Monad v w)
	, Lifting v w
	) => Adaptable w (t :> u :> v :> w) where
	adapt = lift . lift . lift

instance
	( Covariant (t :< u :< v :< w)
	, Lowering t (Schematic Comonad u (v :< w))
	, Lowering u (Schematic Comonad v w)
	, Bringable v w
	) => Adaptable (t :< u :< v :< w) v where
	adapt = bring . lower . lower

instance
	( Covariant (t :< u :< v :< w)
	, Lowering t (Schematic Comonad u v)
	, Lowering t (Schematic Comonad u (v :< w))
	, Lowering u (Schematic Comonad v w)
	, Lowering v w
	) => Adaptable (t :< u :< v :< w) w where
	adapt = lower . lower . lower

instance
	( Covariant (t :> u :> v :> w :> x)
	, Lifting t (Schematic Monad u (v :> w :> x))
	, Lifting u (Schematic Monad v (w :> x))
	, Lifting v (Schematic Monad w x)
	, Lifting w x
	) => Adaptable x (t :> u :> v :> w :> x) where
	adapt = lift . lift . lift . lift

instance
	( Covariant (t :> u :> v :> w :> x)
	, Lifting t (Schematic Monad u (v :> w :> x))
	, Lifting u (Schematic Monad v (w :> x))
	, Lifting v (Schematic Monad w x)
	, Wrappable w x
	) => Adaptable w (t :> u :> v :> w :> x) where
	adapt = lift . lift . lift . wrap

instance
	( Covariant (t :< u :< v :< w :< x)
	, Lowering t (Schematic Comonad u (v :< w :< x))
	, Lowering u (Schematic Comonad v (w :< x))
	, Lowering v (Schematic Comonad w x)
	, Lowering w x
	) => Adaptable (t :< u :< v :< w :< x) x where
	adapt = lower . lower . lower . lower

instance
	( Covariant (t :< u :< v :< w :< x)
	, Lowering t (Schematic Comonad u (v :< w :< x))
	, Lowering u (Schematic Comonad v (w :< x))
	, Lowering v (Schematic Comonad w x)
	, Bringable w x
	) => Adaptable (t :< u :< v :< w :< x) w where
	adapt = bring . lower . lower . lower

instance
	( Covariant (t :> u :> v :> w :> x :> y)
	, Lifting t (Schematic Monad u (v :> w :> x :> y))
	, Lifting u (Schematic Monad v (w :> x :> y))
	, Lifting v (Schematic Monad w (x :> y))
	, Lifting w (Schematic Monad x y)
	, Lifting x y
	) => Adaptable y (t :> u :> v :> w :> x :> y) where
	adapt = lift . lift . lift . lift . lift

instance
	( Covariant (t :> u :> v :> w :> x :> y)
	, Lifting t (Schematic Monad u (v :> w :> x :> y))
	, Lifting u (Schematic Monad v (w :> x :> y))
	, Lifting v (Schematic Monad w (x :> y))
	, Lifting w (Schematic Monad x y)
	, Wrappable x y
	) => Adaptable x (t :> u :> v :> w :> x :> y) where
	adapt = lift . lift . lift . lift . wrap

instance
	( Covariant (t :< u :< v :< w :< x :< y)
	, Lowering t (Schematic Comonad u (v :< w :< x :< y))
	, Lowering u (Schematic Comonad v (w :< x :< y))
	, Lowering v (Schematic Comonad w (x :< y))
	, Lowering w (Schematic Comonad x y)
	, Lowering x y
	) => Adaptable (t :< u :< v :< w :< x :< y) y where
	adapt = lower . lower . lower . lower . lower

instance
	( Covariant (t :< u :< v :< w :< x :< y)
	, Lowering t (Schematic Comonad u (v :< w :< x :< y))
	, Lowering u (Schematic Comonad v (w :< x :< y))
	, Lowering v (Schematic Comonad w (x :< y))
	, Lowering w (Schematic Comonad x y)
	, Bringable x y
	) => Adaptable (t :< u :< v :< w :< x :< y) x where
	adapt = bring . lower . lower . lower . lower

instance
	( Covariant (t :> u :> v :> w :> x :> y :> z)
	, Lifting t (Schematic Monad u (v :> w :> x :> y :> z))
	, Lifting u (Schematic Monad v (w :> x :> y :> z))
	, Lifting v (Schematic Monad w (x :> y :> z))
	, Lifting w (Schematic Monad x (y :> z))
	, Lifting x (Schematic Monad y z)
	, Lifting y z
	) => Adaptable z (t :> u :> v :> w :> x :> y :> z) where
	adapt = lift . lift . lift . lift . lift . lift

instance
	( Covariant (t :> u :> v :> w :> x :> y :> z)
	, Lifting t (Schematic Monad u (v :> w :> x :> y :> z))
	, Lifting u (Schematic Monad v (w :> x :> y :> z))
	, Lifting v (Schematic Monad w (x :> y :> z))
	, Lifting w (Schematic Monad x (y :> z))
	, Lifting x (Schematic Monad y z)
	, Wrappable y z
	) => Adaptable y (t :> u :> v :> w :> x :> y :> z) where
	adapt = lift . lift . lift . lift . lift . wrap

instance
	( Covariant (t :< u :< v :< w :< x :< y :< z)
	, Lowering t (Schematic Comonad u (v :< w :< x :< y :< z))
	, Lowering u (Schematic Comonad v (w :< x :< y :< z))
	, Lowering v (Schematic Comonad w (x :< y :< z))
	, Lowering w (Schematic Comonad x (y :< z))
	, Lowering x (Schematic Comonad y z)
	, Lowering y z
	) => Adaptable (t :< u :< v :< w :< x :< y :< z) z where
	adapt = lower . lower . lower . lower . lower . lower

instance
	( Covariant (t :< u :< v :< w :< x :< y :< z)
	, Lowering t (Schematic Comonad u (v :< w :< x :< y :< z))
	, Lowering u (Schematic Comonad v (w :< x :< y :< z))
	, Lowering v (Schematic Comonad w (x :< y :< z))
	, Lowering w (Schematic Comonad x (y :< z))
	, Lowering x (Schematic Comonad y z)
	, Bringable y z
	) => Adaptable (t :< u :< v :< w :< x :< y :< z) y where
	adapt = bring . lower . lower . lower . lower . lower

instance
	( Covariant (t :> u :> v :> w :> x :> y :> z :> f)
	, Lifting t (Schematic Monad u (v :> w :> x :> y :> z :> f))
	, Lifting u (Schematic Monad v (w :> x :> y :> z :> f))
	, Lifting v (Schematic Monad w (x :> y :> z :> f))
	, Lifting w (Schematic Monad x (y :> z :> f))
	, Lifting x (Schematic Monad y (z :> f))
	, Lifting y (Schematic Monad z f)
	, Lifting z f
	) => Adaptable f (t :> u :> v :> w :> x :> y :> z :> f) where
	adapt = lift . lift . lift . lift . lift . lift . lift

instance
	( Covariant (t :> u :> v :> w :> x :> y :> z :> f)
	, Lifting t (Schematic Monad u (v :> w :> x :> y :> z :> f))
	, Lifting u (Schematic Monad v (w :> x :> y :> z :> f))
	, Lifting v (Schematic Monad w (x :> y :> z :> f))
	, Lifting w (Schematic Monad x (y :> z :> f))
	, Lifting x (Schematic Monad y (z :> f))
	, Lifting y (Schematic Monad z f)
	, Wrappable z f
	) => Adaptable z (t :> u :> v :> w :> x :> y :> z :> f) where
	adapt = lift . lift . lift . lift . lift . lift . wrap

instance
	( Covariant (t :< u :< v :< w :< x :< y :< z :< f)
	, Lowering t (Schematic Comonad u (v :< w :< x :< y :< z :< f))
	, Lowering u (Schematic Comonad v (w :< x :< y :< z :< f))
	, Lowering v (Schematic Comonad w (x :< y :< z :< f))
	, Lowering w (Schematic Comonad x (y :< z :< f))
	, Lowering x (Schematic Comonad y (z :< f))
	, Lowering y (Schematic Comonad z f)
	, Lowering z f
	) => Adaptable (t :< u :< v :< w :< x :< y :< z :< f) f where
	adapt = lower . lower . lower . lower . lower . lower . lower

instance
	( Covariant (t :< u :< v :< w :< x :< y :< z :< f)
	, Lowering t (Schematic Comonad u (v :< w :< x :< y :< z :< f))
	, Lowering u (Schematic Comonad v (w :< x :< y :< z :< f))
	, Lowering v (Schematic Comonad w (x :< y :< z :< f))
	, Lowering w (Schematic Comonad x (y :< z :< f))
	, Lowering x (Schematic Comonad y (z :< f))
	, Lowering y (Schematic Comonad z f)
	, Bringable z f
	) => Adaptable (t :< u :< v :< w :< x :< y :< z :< f) z where
	adapt = bring . lower . lower . lower . lower . lower . lower

instance
	( Covariant (t :> u :> v :> w :> x :> y :> z :> f :> h)
	, Lifting t (Schematic Monad u (v :> w :> x :> y :> z :> f :> h))
	, Lifting u (Schematic Monad v (w :> x :> y :> z :> f :> h))
	, Lifting v (Schematic Monad w (x :> y :> z :> f :> h))
	, Lifting w (Schematic Monad x (y :> z :> f :> h))
	, Lifting x (Schematic Monad y (z :> f :> h))
	, Lifting y (Schematic Monad z (f :> h))
	, Lifting z (Schematic Monad f h)
	, Lifting f h
	) => Adaptable h (t :> u :> v :> w :> x :> y :> z :> f :> h) where
	adapt = lift . lift . lift . lift . lift . lift . lift . lift

instance
	( Covariant (t :> u :> v :> w :> x :> y :> z :> f :> h)
	, Lifting t (Schematic Monad u (v :> w :> x :> y :> z :> f :> h))
	, Lifting u (Schematic Monad v (w :> x :> y :> z :> f :> h))
	, Lifting v (Schematic Monad w (x :> y :> z :> f :> h))
	, Lifting w (Schematic Monad x (y :> z :> f :> h))
	, Lifting x (Schematic Monad y (z :> f :> h))
	, Lifting y (Schematic Monad z (f :> h))
	, Lifting z (Schematic Monad f h)
	, Wrappable f h
	) => Adaptable f (t :> u :> v :> w :> x :> y :> z :> f :> h) where
	adapt = lift . lift . lift . lift . lift . lift . lift . wrap

instance
	( Covariant (t :< u :< v :< w :< x :< y :< z :< f :< h)
	, Lowering t (Schematic Comonad u (v :< w :< x :< y :< z :< f :< h))
	, Lowering u (Schematic Comonad v (w :< x :< y :< z :< f :< h))
	, Lowering v (Schematic Comonad w (x :< y :< z :< f :< h))
	, Lowering w (Schematic Comonad x (y :< z :< f :< h))
	, Lowering x (Schematic Comonad y (z :< f :< h))
	, Lowering y (Schematic Comonad z (f :< h))
	, Lowering z (Schematic Comonad f h)
	, Lowering f h
	) => Adaptable (t :< u :< v :< w :< x :< y :< z :< f :< h) h where
	adapt = lower . lower . lower . lower . lower . lower . lower . lower

instance
	( Covariant (t :< u :< v :< w :< x :< y :< z :< f :< h)
	, Lowering t (Schematic Comonad u (v :< w :< x :< y :< z :< f :< h))
	, Lowering u (Schematic Comonad v (w :< x :< y :< z :< f :< h))
	, Lowering v (Schematic Comonad w (x :< y :< z :< f :< h))
	, Lowering w (Schematic Comonad x (y :< z :< f :< h))
	, Lowering x (Schematic Comonad y (z :< f :< h))
	, Lowering y (Schematic Comonad z (f :< h))
	, Lowering z (Schematic Comonad f h)
	, Bringable f h
	) => Adaptable (t :< u :< v :< w :< x :< y :< z :< f :< h) f where
	adapt = bring . lower . lower . lower . lower . lower . lower . lower

instance (Covariant u, Hoistable ((:>) t), Adaptable u u') => Adaptable (t :> u) (t :> u') where
	adapt = hoist adapt

instance
	( Covariant u
	, Covariant v
	, Traversable (Schematic Monad u v)
	, Hoistable ((:>) (t :> u))
	, Hoistable (Schematic Monad t)
	, Hoistable (Schematic Monad u)
	, Adaptable v v'
	) => Adaptable (t :> u :> v) (t :> u :> v') where
	adapt = hoist (hoist adapt)

instance
	( Covariant u, Covariant v, Covariant w
	, Traversable (Schematic Monad u v)
	, Traversable (Schematic Monad u (v :> w))
	, Traversable (Schematic Monad v w)
	, Hoistable ((:>) (t :> u :> v))
	, Hoistable (Schematic Monad t)
	, Hoistable (Schematic Monad u)
	, Hoistable (Schematic Monad v)
	, Adaptable w w'
	) => Adaptable (t :> u :> v :> w) (t :> u :> v :> w') where
	adapt = hoist (hoist (hoist adapt))

instance
	( Covariant u, Covariant v, Covariant w, Covariant x
	, Traversable (Schematic Monad u v)
	, Traversable (Schematic Monad u (v :> w))
	, Traversable (Schematic Monad v (w :> x))
	, Traversable (Schematic Monad u (v :> (w :> x)))
	, Traversable (Schematic Monad w x)
	, Hoistable ((:>) (t :> u :> v))
	, Hoistable (Schematic Monad t)
	, Hoistable (Schematic Monad u)
	, Hoistable (Schematic Monad v)
	, Hoistable (Schematic Monad w)
	, Adaptable x x'
	) => Adaptable (t :> u :> v :> w :> x) (t :> u :> v :> w :> x') where
	adapt = hoist (hoist (hoist (hoist adapt)))