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