module Control.Joint.Abilities.Transformer where

import "base" Control.Applicative (Alternative (empty, (<|>)))
import "transformers" Control.Monad.Trans.Class (MonadTrans (lift))

import Control.Joint.Core (type (~>))
import Control.Joint.Abilities.Interpreted (Interpreted (Primary, run))

type family Schema (t :: * -> *) = (r :: (* -> *) -> * -> *) | r -> t

class Interpreted t => Transformer t where
	{-# MINIMAL build, unite #-}
	build :: Applicative u => t ~> t :> u
	unite :: Primary (Schema t u) a -> (t :> u) a

infixr 3 :>
newtype (:>) t u a = T { (:>) t u a -> Transformer t => Schema t u a
trans :: Transformer t => Schema t u a }

instance Functor (Schema t u) => Functor (t :> u) where
	fmap :: (a -> b) -> (:>) t u a -> (:>) t u b
fmap a -> b
f (T Transformer t => Schema t u a
x) = (Transformer t => Schema t u b) -> (:>) t u b
forall (t :: * -> *) (u :: * -> *) a.
(Transformer t => Schema t u a) -> (:>) t u a
T ((Transformer t => Schema t u b) -> (:>) t u b)
-> (Transformer t => Schema t u b) -> (:>) t u b
forall a b. (a -> b) -> a -> b
$ a -> b
f (a -> b) -> Schema t u a -> Schema t u b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Schema t u a
Transformer t => Schema t u a
x

instance (Transformer t, Applicative (Schema t u)) => Applicative (t :> u) where
	pure :: a -> (:>) t u a
pure = Schema t u a -> (:>) t u a
forall (t :: * -> *) (u :: * -> *) a.
(Transformer t => Schema t u a) -> (:>) t u a
T (Schema t u a -> (:>) t u a)
-> (a -> Schema t u a) -> a -> (:>) t u a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Schema t u a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
	T Transformer t => Schema t u (a -> b)
f <*> :: (:>) t u (a -> b) -> (:>) t u a -> (:>) t u b
<*> T Transformer t => Schema t u a
x = (Transformer t => Schema t u b) -> (:>) t u b
forall (t :: * -> *) (u :: * -> *) a.
(Transformer t => Schema t u a) -> (:>) t u a
T ((Transformer t => Schema t u b) -> (:>) t u b)
-> (Transformer t => Schema t u b) -> (:>) t u b
forall a b. (a -> b) -> a -> b
$ Schema t u (a -> b)
Transformer t => Schema t u (a -> b)
f Schema t u (a -> b) -> Schema t u a -> Schema t u b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Schema t u a
Transformer t => Schema t u a
x

instance (Transformer t, Alternative (Schema t u)) => Alternative (t :> u) where
	empty :: (:>) t u a
empty = (Transformer t => Schema t u a) -> (:>) t u a
forall (t :: * -> *) (u :: * -> *) a.
(Transformer t => Schema t u a) -> (:>) t u a
T Transformer t => Schema t u a
forall (f :: * -> *) a. Alternative f => f a
empty
	T Transformer t => Schema t u a
f <|> :: (:>) t u a -> (:>) t u a -> (:>) t u a
<|> T Transformer t => Schema t u a
x = (Transformer t => Schema t u a) -> (:>) t u a
forall (t :: * -> *) (u :: * -> *) a.
(Transformer t => Schema t u a) -> (:>) t u a
T ((Transformer t => Schema t u a) -> (:>) t u a)
-> (Transformer t => Schema t u a) -> (:>) t u a
forall a b. (a -> b) -> a -> b
$ Schema t u a
Transformer t => Schema t u a
f Schema t u a -> Schema t u a -> Schema t u a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Schema t u a
Transformer t => Schema t u a
x

instance (Transformer t, Monad (Schema t u)) => Monad (t :> u) where
	T Transformer t => Schema t u a
x >>= :: (:>) t u a -> (a -> (:>) t u b) -> (:>) t u b
>>= a -> (:>) t u b
f = (Transformer t => Schema t u b) -> (:>) t u b
forall (t :: * -> *) (u :: * -> *) a.
(Transformer t => Schema t u a) -> (:>) t u a
T ((Transformer t => Schema t u b) -> (:>) t u b)
-> (Transformer t => Schema t u b) -> (:>) t u b
forall a b. (a -> b) -> a -> b
$ Schema t u a
Transformer t => Schema t u a
x Schema t u a -> (a -> Schema t u b) -> Schema t u b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (:>) t u b -> Schema t u b
forall (t :: * -> *) (u :: * -> *) a.
(:>) t u a -> Transformer t => Schema t u a
trans ((:>) t u b -> Schema t u b)
-> (a -> (:>) t u b) -> a -> Schema t u b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> (:>) t u b
f

instance (Interpreted (Schema t u), Transformer t) => Interpreted (t :> u) where
	type Primary (t :> u) a = Primary (Schema t u) a
	run :: (:>) t u a -> Primary (t :> u) a
run (T Transformer t => Schema t u a
x) = Schema t u a -> Primary (Schema t u) a
forall (t :: * -> *) a. Interpreted t => t a -> Primary t a
run Schema t u a
Transformer t => Schema t u a
x

instance MonadTrans (Schema t) => MonadTrans ((:>) t) where
	lift :: m a -> (:>) t m a
lift = Schema t m a -> (:>) t m a
forall (t :: * -> *) (u :: * -> *) a.
(Transformer t => Schema t u a) -> (:>) t u a
T (Schema t m a -> (:>) t m a)
-> (m a -> Schema t m a) -> m a -> (:>) t m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m a -> Schema t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift