Liftable.hs

module Control.Joint.Abilities.Liftable where

import Control.Joint.Core (type (~>))
import Control.Joint.Abilities.Interpreted (Interpreted (run))
import Control.Joint.Abilities.Transformer (Transformer (Schema, build, embed), (:>) (T, trans))

class Liftable (eff :: * -> *) (schema :: * -> *) where
	{-# MINIMAL lift #-}
	lift :: eff ~> schema

type Embedding t u = (Transformer t, Functor u)
type Building t u = (Transformer t, Applicative u)

instance Liftable t t where
	lift = id

instance Embedding t u => Liftable u (t :> u) where
	lift = embed

instance Building t u => Liftable t (t :> u) where
	lift = build

instance
	( Embedding t (Schema u v)
	, Building u v
	) => Liftable u (t :> u :> v) where
	lift = embed . build

instance
	( Embedding t (Schema u v)
	, Embedding u v
	) => Liftable v (t :> u :> v) where
	lift = embed . embed

instance
	( Embedding t (Schema u (v :> w))
	, Embedding u (Schema v w)
	, Building v w
	) => Liftable v (t :> u :> v :> w) where
	lift = embed . embed . build

instance
	( Embedding t (Schema u v)
	, Embedding t (Schema u (v :> w))
	, Embedding u (Schema v w)
	, Embedding v w
	) => Liftable w (t :> u :> v :> w) where
	lift = embed . embed . embed

instance (Embedding t (Schema u (v :> w :> x))
	, Embedding u (Schema v (w :> x))
	, Embedding v (Schema w x)
	, Embedding w x
	) => Liftable x (t :> u :> v :> w :> x) where
	lift = embed . embed . embed . embed

instance (Embedding t (Schema u (v :> w :> x))
	, Embedding u (Schema v (w :> x))
	, Embedding v (Schema w x)
	, Building w x
	) => Liftable w (t :> u :> v :> w :> x) where
	lift = embed . embed . embed . build

instance
	( Embedding t (Schema u (v :> w :> x :> y))
	, Embedding u (Schema v (w :> x :> y))
	, Embedding v (Schema w (x :> y))
	, Embedding w (Schema x y)
	, Embedding x y
	) => Liftable y (t :> u :> v :> w :> x :> y) where
	lift = embed . embed . embed . embed . embed

instance
	( Embedding t (Schema u (v :> w :> x :> y))
	, Embedding u (Schema v (w :> x :> y))
	, Embedding v (Schema w (x :> y))
	, Embedding w (Schema x y)
	, Building x y
	) => Liftable x (t :> u :> v :> w :> x :> y) where
	lift = embed . embed . embed . embed . build

instance
	( Embedding t (Schema u (v :> w :> x :> y :> z))
	, Embedding u (Schema v (w :> x :> y :> z))
	, Embedding v (Schema w (x :> y :> z))
	, Embedding w (Schema x (y :> z))
	, Embedding x (Schema y z)
	, Embedding y z
	) => Liftable z (t :> u :> v :> w :> x :> y :> z) where
	lift = embed . embed . embed . embed . embed . embed

instance
	( Embedding t (Schema u (v :> w :> x :> y :> z))
	, Embedding u (Schema v (w :> x :> y :> z))
	, Embedding v (Schema w (x :> y :> z))
	, Embedding w (Schema x (y :> z))
	, Embedding x (Schema y z)
	, Building y z
	) => Liftable y (t :> u :> v :> w :> x :> y :> z) where
	lift = embed . embed . embed . embed . embed . build

instance
	( Embedding t (Schema u (v :> w :> x :> y :> z :> f))
	, Embedding u (Schema v (w :> x :> y :> z :> f))
	, Embedding v (Schema w (x :> y :> z :> f))
	, Embedding w (Schema x (y :> z :> f))
	, Embedding x (Schema y (z :> f))
	, Embedding y (Schema z f)
	, Embedding z f
	) => Liftable f (t :> u :> v :> w :> x :> y :> z :> f) where
	lift = embed . embed . embed . embed . embed . embed . embed

instance
	( Embedding t (Schema u (v :> w :> x :> y :> z :> f))
	, Embedding u (Schema v (w :> x :> y :> z :> f))
	, Embedding v (Schema w (x :> y :> z :> f))
	, Embedding w (Schema x (y :> z :> f))
	, Embedding x (Schema y (z :> f))
	, Embedding y (Schema z f)
	, Building z f
	) => Liftable z (t :> u :> v :> w :> x :> y :> z :> f) where
	lift = embed . embed . embed . embed . embed . embed . build

instance
	( Embedding t (Schema u (v :> w :> x :> y :> z :> f :> h))
	, Embedding u (Schema v (w :> x :> y :> z :> f :> h))
	, Embedding v (Schema w (x :> y :> z :> f :> h))
	, Embedding w (Schema x (y :> z :> f :> h))
	, Embedding x (Schema y (z :> f :> h))
	, Embedding y (Schema z (f :> h))
	, Embedding z (Schema f h)
	, Embedding f h
	) => Liftable h (t :> u :> v :> w :> x :> y :> z :> f :> h) where
	lift = embed . embed . embed . embed . embed . embed . embed . embed

instance
	( Embedding t (Schema u (v :> w :> x :> y :> z :> f :> h))
	, Embedding u (Schema v (w :> x :> y :> z :> f :> h))
	, Embedding v (Schema w (x :> y :> z :> f :> h))
	, Embedding w (Schema x (y :> z :> f :> h))
	, Embedding x (Schema y (z :> f :> h))
	, Embedding y (Schema z (f :> h))
	, Embedding z (Schema f h)
	, Building f h
	) => Liftable f (t :> u :> v :> w :> x :> y :> z :> f :> h) where
	lift = embed . embed . embed . embed . embed . embed . embed . build