{-# 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)