{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE NoImplicitPrelude #-} module Data.Morpheus.Server.Deriving.App ( RootResolverConstraint, deriveSchema, deriveApp, ) where import Data.Morpheus.App ( App (..), mkApp, ) import Data.Morpheus.App.Internal.Resolving ( resultOr, ) import Data.Morpheus.Server.Deriving.Resolvers ( DERIVE_NAMED_RESOLVERS, DERIVE_RESOLVERS, deriveNamedResolvers, deriveResolvers, ) import Data.Morpheus.Server.Deriving.Schema ( SCHEMA, deriveSchema, ) import Data.Morpheus.Server.Resolvers ( NamedResolvers, ) import Data.Morpheus.Server.Types import Relude type RootResolverConstraint m e query mutation subscription = ( DERIVE_RESOLVERS (Resolver QUERY e m) query mutation subscription, SCHEMA query mutation subscription, Monad m ) type NamedResolversConstraint m e query mutation subscription = ( DERIVE_NAMED_RESOLVERS (Resolver QUERY e m) query, SCHEMA query mutation subscription, Monad m ) class DeriveApp f m (event :: Type) (qu :: (Type -> Type) -> Type) (mu :: (Type -> Type) -> Type) (su :: (Type -> Type) -> Type) where deriveApp :: f m event qu mu su -> App event m instance RootResolverConstraint m e query mut sub => DeriveApp RootResolver m e query mut sub where deriveApp :: RootResolver m e query mut sub -> App e m deriveApp RootResolver m e query mut sub root = forall err a' a. (NonEmpty err -> a') -> (a -> a') -> Result err a -> a' resultOr forall event (m :: * -> *). GQLErrors -> App event m FailApp (forall a b c. (a -> b -> c) -> (a, b) -> c uncurry forall (s :: Stage) e (m :: * -> *). ValidateSchema s => Schema s -> RootResolverValue e m -> App e m mkApp) forall a b. (a -> b) -> a -> b $ (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> forall {k1} {k2} {k3} (root :: k1 -> k2 -> ((* -> *) -> *) -> ((* -> *) -> *) -> ((* -> *) -> *) -> k3) (f :: k3 -> *) (m :: k1) (e :: k2) (qu :: (* -> *) -> *) (mu :: (* -> *) -> *) (su :: (* -> *) -> *). SCHEMA qu mu su => f (root m e qu mu su) -> GQLResult (Schema CONST) deriveSchema (forall a. a -> Identity a Identity RootResolver m e query mut sub root) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> forall (m :: * -> *) e (query :: (* -> *) -> *) (mut :: (* -> *) -> *) (sub :: (* -> *) -> *). (Monad m, DERIVE_RESOLVERS (Resolver QUERY e m) query mut sub) => RootResolver m e query mut sub -> GQLResult (RootResolverValue e m) deriveResolvers RootResolver m e query mut sub root instance NamedResolversConstraint m e query mut sub => DeriveApp NamedResolvers m e query mut sub where deriveApp :: NamedResolvers m e query mut sub -> App e m deriveApp NamedResolvers m e query mut sub root = forall err a' a. (NonEmpty err -> a') -> (a -> a') -> Result err a -> a' resultOr forall event (m :: * -> *). GQLErrors -> App event m FailApp (forall a b c. (a -> b -> c) -> (a, b) -> c uncurry forall (s :: Stage) e (m :: * -> *). ValidateSchema s => Schema s -> RootResolverValue e m -> App e m mkApp) forall a b. (a -> b) -> a -> b $ (,forall e (m :: * -> *) (query :: (* -> *) -> *) (mut :: (* -> *) -> *) (sub :: (* -> *) -> *). (Monad m, DERIVE_NAMED_RESOLVERS (Resolver QUERY e m) query) => NamedResolvers m e query mut sub -> RootResolverValue e m deriveNamedResolvers NamedResolvers m e query mut sub root) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> forall {k1} {k2} {k3} (root :: k1 -> k2 -> ((* -> *) -> *) -> ((* -> *) -> *) -> ((* -> *) -> *) -> k3) (f :: k3 -> *) (m :: k1) (e :: k2) (qu :: (* -> *) -> *) (mu :: (* -> *) -> *) (su :: (* -> *) -> *). SCHEMA qu mu su => f (root m e qu mu su) -> GQLResult (Schema CONST) deriveSchema (forall a. a -> Identity a Identity NamedResolvers m e query mut sub root)