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

import Pandora.Core.Morphism (identity, (.))
import Pandora.Core.Transformation (type (~>))
import Pandora.Pattern.Functor.Covariant (Covariant)
import Pandora.Pattern.Functor.Pointable (Pointable)
import Pandora.Paradigm.Controlflow.Joint.Transformer (Transformer (Schema, lay, wrap), (:>))

class Adaptable eff schema where
        {-# MINIMAL adapt #-}
        adapt :: eff ~> schema

type Layable t u = (Transformer t, Covariant u)
type Wrappable t u = (Transformer t, Pointable u)

instance Adaptable t t where
        adapt = identity

instance Layable t u => Adaptable u (t :> u) where
        adapt = lay

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

instance
        ( Layable t (Schema u v)
        , Wrappable u v
        ) => Adaptable u (t :> u :> v) where
        adapt = lay . wrap

instance
        ( Layable t (Schema u v)
        , Layable u v
        ) => Adaptable v (t :> u :> v) where
        adapt = lay . lay

instance
        ( Layable t (Schema u (v :> w))
        , Layable u (Schema v w)
        , Wrappable v w
        ) => Adaptable v (t :> u :> v :> w) where
        adapt = lay . lay . wrap

instance
        ( Layable t (Schema u v)
        , Layable t (Schema u (v :> w))
        , Layable u (Schema v w)
        , Layable v w
        ) => Adaptable w (t :> u :> v :> w) where
        adapt = lay . lay . lay

instance (Layable t (Schema u (v :> w :> x))
        , Layable u (Schema v (w :> x))
        , Layable v (Schema w x)
        , Layable w x
        ) => Adaptable x (t :> u :> v :> w :> x) where
        adapt = lay . lay . lay . lay

instance (Layable t (Schema u (v :> w :> x))
        , Layable u (Schema v (w :> x))
        , Layable v (Schema w x)
        , Wrappable w x
        ) => Adaptable w (t :> u :> v :> w :> x) where
        adapt = lay . lay . lay . wrap

instance
        ( Layable t (Schema u (v :> w :> x :> y))
        , Layable u (Schema v (w :> x :> y))
        , Layable v (Schema w (x :> y))
        , Layable w (Schema x y)
        , Layable x y
        ) => Adaptable y (t :> u :> v :> w :> x :> y) where
        adapt = lay . lay . lay . lay . lay

instance
        ( Layable t (Schema u (v :> w :> x :> y))
        , Layable u (Schema v (w :> x :> y))
        , Layable v (Schema w (x :> y))
        , Layable w (Schema x y)
        , Wrappable x y
        ) => Adaptable x (t :> u :> v :> w :> x :> y) where
        adapt = lay . lay . lay . lay . wrap

instance
        ( Layable t (Schema u (v :> w :> x :> y :> z))
        , Layable u (Schema v (w :> x :> y :> z))
        , Layable v (Schema w (x :> y :> z))
        , Layable w (Schema x (y :> z))
        , Layable x (Schema y z)
        , Layable y z
        ) => Adaptable z (t :> u :> v :> w :> x :> y :> z) where
        adapt = lay . lay . lay . lay . lay . lay

instance
        ( Layable t (Schema u (v :> w :> x :> y :> z))
        , Layable u (Schema v (w :> x :> y :> z))
        , Layable v (Schema w (x :> y :> z))
        , Layable w (Schema x (y :> z))
        , Layable x (Schema y z)
        , Wrappable y z
        ) => Adaptable y (t :> u :> v :> w :> x :> y :> z) where
        adapt = lay . lay . lay . lay . lay . wrap

instance
        ( Layable t (Schema u (v :> w :> x :> y :> z :> f))
        , Layable u (Schema v (w :> x :> y :> z :> f))
        , Layable v (Schema w (x :> y :> z :> f))
        , Layable w (Schema x (y :> z :> f))
        , Layable x (Schema y (z :> f))
        , Layable y (Schema z f)
        , Layable z f
        ) => Adaptable f (t :> u :> v :> w :> x :> y :> z :> f) where
        adapt = lay . lay . lay . lay . lay . lay . lay

instance
        ( Layable t (Schema u (v :> w :> x :> y :> z :> f))
        , Layable u (Schema v (w :> x :> y :> z :> f))
        , Layable v (Schema w (x :> y :> z :> f))
        , Layable w (Schema x (y :> z :> f))
        , Layable x (Schema y (z :> f))
        , Layable y (Schema z f)
        , Wrappable z f
        ) => Adaptable z (t :> u :> v :> w :> x :> y :> z :> f) where
        adapt = lay . lay . lay . lay . lay . lay . wrap

instance
        ( Layable t (Schema u (v :> w :> x :> y :> z :> f :> h))
        , Layable u (Schema v (w :> x :> y :> z :> f :> h))
        , Layable v (Schema w (x :> y :> z :> f :> h))
        , Layable w (Schema x (y :> z :> f :> h))
        , Layable x (Schema y (z :> f :> h))
        , Layable y (Schema z (f :> h))
        , Layable z (Schema f h)
        , Layable f h
        ) => Adaptable h (t :> u :> v :> w :> x :> y :> z :> f :> h) where
        adapt = lay . lay . lay . lay . lay . lay . lay . lay

instance
        ( Layable t (Schema u (v :> w :> x :> y :> z :> f :> h))
        , Layable u (Schema v (w :> x :> y :> z :> f :> h))
        , Layable v (Schema w (x :> y :> z :> f :> h))
        , Layable w (Schema x (y :> z :> f :> h))
        , Layable x (Schema y (z :> f :> h))
        , Layable y (Schema z (f :> h))
        , Layable z (Schema f h)
        , Wrappable f h
        ) => Adaptable f (t :> u :> v :> w :> x :> y :> z :> f :> h) where
        adapt = lay . lay . lay . lay . lay . lay . lay . wrap