{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# 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.Encode
  ( EncodeConstraints,
    deriveModel,
  )
import Data.Morpheus.Server.Deriving.Named.Encode
  ( EncodeNamedConstraints,
    deriveNamedModel,
  )
import Data.Morpheus.Server.Deriving.Schema
  ( SchemaConstraints,
    deriveSchema,
  )
import Data.Morpheus.Types
  ( NamedResolvers,
    RootResolver (..),
  )
import Relude

type RootResolverConstraint m e query mutation subscription =
  ( EncodeConstraints e m query mutation subscription,
    SchemaConstraints e m query mutation subscription,
    Monad m
  )

type NamedResolversConstraint m e query mutation subscription =
  ( EncodeNamedConstraints e m query mutation subscription,
    SchemaConstraints e m query mutation subscription,
    Monad m
  )

class DeriveApp f m (event :: *) (query :: (* -> *) -> *) (mut :: (* -> *) -> *) (sub :: (* -> *) -> *) where
  deriveApp :: f m event query mut sub -> 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 =
    (NonEmpty GQLError -> App e m)
-> ((Schema CONST, RootResolverValue e m) -> App e m)
-> Result GQLError (Schema CONST, RootResolverValue e m)
-> App e m
forall err a' a.
(NonEmpty err -> a') -> (a -> a') -> Result err a -> a'
resultOr NonEmpty GQLError -> App e m
forall event (m :: * -> *). NonEmpty GQLError -> App event m
FailApp ((Schema CONST -> RootResolverValue e m -> App e m)
-> (Schema CONST, RootResolverValue e m) -> App e m
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Schema CONST -> RootResolverValue e m -> App e m
forall (s :: Stage) e (m :: * -> *).
ValidateSchema s =>
Schema s -> RootResolverValue e m -> App e m
mkApp) (Result GQLError (Schema CONST, RootResolverValue e m) -> App e m)
-> Result GQLError (Schema CONST, RootResolverValue e m) -> App e m
forall a b. (a -> b) -> a -> b
$
      (,) (Schema CONST
 -> RootResolverValue e m -> (Schema CONST, RootResolverValue e m))
-> Result GQLError (Schema CONST)
-> Result
     GQLError
     (RootResolverValue e m -> (Schema CONST, RootResolverValue e m))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Identity (RootResolver m e query mut sub)
-> Result GQLError (Schema CONST)
forall k
       (root :: (* -> *)
                -> * -> ((* -> *) -> *) -> ((* -> *) -> *) -> ((* -> *) -> *) -> k)
       (proxy :: k -> *) (m :: * -> *) e (query :: (* -> *) -> *)
       (mut :: (* -> *) -> *) (subs :: (* -> *) -> *).
SchemaConstraints e m query mut subs =>
proxy (root m e query mut subs) -> Result GQLError (Schema CONST)
deriveSchema (RootResolver m e query mut sub
-> Identity (RootResolver m e query mut sub)
forall a. a -> Identity a
Identity RootResolver m e query mut sub
root) Result
  GQLError
  (RootResolverValue e m -> (Schema CONST, RootResolverValue e m))
-> Result GQLError (RootResolverValue e m)
-> Result GQLError (Schema CONST, RootResolverValue e m)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> RootResolver m e query mut sub
-> Result GQLError (RootResolverValue e m)
forall e (m :: * -> *) (query :: (* -> *) -> *)
       (mut :: (* -> *) -> *) (sub :: (* -> *) -> *).
(Monad m, EncodeConstraints e m query mut sub) =>
RootResolver m e query mut sub -> GQLResult (RootResolverValue e m)
deriveModel 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 =
    (NonEmpty GQLError -> App e m)
-> ((Schema CONST, RootResolverValue e m) -> App e m)
-> Result GQLError (Schema CONST, RootResolverValue e m)
-> App e m
forall err a' a.
(NonEmpty err -> a') -> (a -> a') -> Result err a -> a'
resultOr NonEmpty GQLError -> App e m
forall event (m :: * -> *). NonEmpty GQLError -> App event m
FailApp ((Schema CONST -> RootResolverValue e m -> App e m)
-> (Schema CONST, RootResolverValue e m) -> App e m
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Schema CONST -> RootResolverValue e m -> App e m
forall (s :: Stage) e (m :: * -> *).
ValidateSchema s =>
Schema s -> RootResolverValue e m -> App e m
mkApp) (Result GQLError (Schema CONST, RootResolverValue e m) -> App e m)
-> Result GQLError (Schema CONST, RootResolverValue e m) -> App e m
forall a b. (a -> b) -> a -> b
$
      (,NamedResolvers m e query mut sub -> RootResolverValue e m
forall e (m :: * -> *) (query :: (* -> *) -> *)
       (mut :: (* -> *) -> *) (sub :: (* -> *) -> *).
(Monad m, EncodeNamedConstraints e m query mut sub) =>
NamedResolvers m e query mut sub -> RootResolverValue e m
deriveNamedModel NamedResolvers m e query mut sub
root) (Schema CONST -> (Schema CONST, RootResolverValue e m))
-> Result GQLError (Schema CONST)
-> Result GQLError (Schema CONST, RootResolverValue e m)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Identity (NamedResolvers m e query mut sub)
-> Result GQLError (Schema CONST)
forall k
       (root :: (* -> *)
                -> * -> ((* -> *) -> *) -> ((* -> *) -> *) -> ((* -> *) -> *) -> k)
       (proxy :: k -> *) (m :: * -> *) e (query :: (* -> *) -> *)
       (mut :: (* -> *) -> *) (subs :: (* -> *) -> *).
SchemaConstraints e m query mut subs =>
proxy (root m e query mut subs) -> Result GQLError (Schema CONST)
deriveSchema (NamedResolvers m e query mut sub
-> Identity (NamedResolvers m e query mut sub)
forall a. a -> Identity a
Identity NamedResolvers m e query mut sub
root)