{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE NoImplicitPrelude #-}

module Data.Morpheus.Server.Deriving.Encode
  ( deriveModel,
    EncodeConstraints,
    ContextValue (..),
  )
where

import Control.Monad.Except (MonadError)
import qualified Data.Map as M
import Data.Morpheus.App.Internal.Resolving
  ( LiftOperation,
    ObjectTypeResolver,
    Resolver,
    ResolverState,
    ResolverValue (..),
    RootResolverValue (..),
    getArguments,
    liftResolverState,
    mkEnum,
    mkObject,
    mkUnion,
    requireObject,
  )
import Data.Morpheus.Internal.Ext (GQLResult)
import Data.Morpheus.Kind
  ( CUSTOM,
    DerivingKind,
    SCALAR,
    TYPE,
    WRAPPER,
  )
import Data.Morpheus.Server.Deriving.Channels
  ( ChannelsConstraint,
    channelResolver,
  )
import Data.Morpheus.Server.Deriving.Decode
  ( Decode,
    decodeArguments,
  )
import Data.Morpheus.Server.Deriving.Utils
  ( ConsRep (..),
    DataType (..),
    FieldRep (..),
    isUnionRef,
    toFieldRes,
  )
import Data.Morpheus.Server.Deriving.Utils.DeriveGType
  ( DeriveValueOptions (..),
    DeriveWith,
    deriveValue,
  )
import Data.Morpheus.Server.Deriving.Utils.Kinded (KindedProxy (KindedProxy), kinded)
import Data.Morpheus.Server.Types.GQLType
  ( GQLType (typeOptions),
    KIND,
    deriveTypename,
    __isEmptyType,
    __typeData,
  )
import Data.Morpheus.Server.Types.Types
  ( TypeGuard (..),
  )
import Data.Morpheus.Types
  ( RootResolver (..),
    defaultTypeOptions,
  )
import Data.Morpheus.Types.GQLScalar
  ( EncodeScalar (..),
  )
import Data.Morpheus.Types.GQLWrapper (EncodeWrapper (..))
import Data.Morpheus.Types.Internal.AST
  ( GQLError,
    IN,
    MUTATION,
    OperationType,
    QUERY,
    SUBSCRIPTION,
    TypeRef (..),
  )
import GHC.Generics
  ( Generic (..),
  )
import Relude

newtype ContextValue (kind :: DerivingKind) a = ContextValue
  { forall (kind :: DerivingKind) a. ContextValue kind a -> a
unContextValue :: a
  }

class Encode (m :: Type -> Type) resolver where
  encode :: resolver -> m (ResolverValue m)

instance (EncodeKind (KIND a) m a) => Encode m a where
  encode :: a -> m (ResolverValue m)
encode a
resolver = forall (kind :: DerivingKind) (m :: * -> *) a.
EncodeKind kind m a =>
ContextValue kind a -> m (ResolverValue m)
encodeKind (forall (kind :: DerivingKind) a. a -> ContextValue kind a
ContextValue a
resolver :: ContextValue (KIND a) a)

-- ENCODE GQL KIND
class EncodeKind (kind :: DerivingKind) (m :: Type -> Type) (a :: Type) where
  encodeKind :: ContextValue kind a -> m (ResolverValue m)

instance
  ( EncodeWrapper f,
    Encode m a,
    Monad m
  ) =>
  EncodeKind WRAPPER m (f a)
  where
  encodeKind :: ContextValue WRAPPER (f a) -> m (ResolverValue m)
encodeKind = forall (wrapper :: * -> *) (m :: * -> *) a.
(EncodeWrapper wrapper, Monad m) =>
(a -> m (ResolverValue m)) -> wrapper a -> m (ResolverValue m)
encodeWrapper forall (m :: * -> *) resolver.
Encode m resolver =>
resolver -> m (ResolverValue m)
encode forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (kind :: DerivingKind) a. ContextValue kind a -> a
unContextValue

instance
  ( EncodeScalar a,
    Monad m
  ) =>
  EncodeKind SCALAR m a
  where
  encodeKind :: ContextValue SCALAR a -> m (ResolverValue m)
encodeKind = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). ScalarValue -> ResolverValue m
ResScalar forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. EncodeScalar a => a -> ScalarValue
encodeScalar forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (kind :: DerivingKind) a. ContextValue kind a -> a
unContextValue

instance
  ( EncodeConstraint m a,
    MonadError GQLError m
  ) =>
  EncodeKind TYPE m a
  where
  encodeKind :: ContextValue TYPE a -> m (ResolverValue m)
encodeKind = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a.
(EncodeConstraint m a, MonadError GQLError m) =>
a -> ResolverValue m
exploreResolvers forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (kind :: DerivingKind) a. ContextValue kind a -> a
unContextValue

--  Map
instance (Monad m, Encode m [(k, v)]) => EncodeKind CUSTOM m (Map k v) where
  encodeKind :: ContextValue CUSTOM (Map k v) -> m (ResolverValue m)
encodeKind = forall (m :: * -> *) resolver.
Encode m resolver =>
resolver -> m (ResolverValue m)
encode forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [(k, a)]
M.toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (kind :: DerivingKind) a. ContextValue kind a -> a
unContextValue

--  INTERFACE Types
instance (MonadError GQLError m, EncodeConstraint m guard, EncodeConstraint m union) => EncodeKind CUSTOM m (TypeGuard guard union) where
  encodeKind :: ContextValue CUSTOM (TypeGuard guard union) -> m (ResolverValue m)
encodeKind (ContextValue (ResolveType union
value)) = forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall (m :: * -> *) a.
(EncodeConstraint m a, MonadError GQLError m) =>
a -> ResolverValue m
exploreResolvers union
value)
  encodeKind (ContextValue (ResolveInterface guard
value)) = forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall (m :: * -> *) a.
(EncodeConstraint m a, MonadError GQLError m) =>
a -> ResolverValue m
exploreResolvers guard
value)

--  GQL a -> Resolver b, MUTATION, SUBSCRIPTION, QUERY
instance
  ( Decode a,
    Generic a,
    Monad m,
    Encode (Resolver o e m) b,
    LiftOperation o
  ) =>
  EncodeKind CUSTOM (Resolver o e m) (a -> b)
  where
  encodeKind :: ContextValue CUSTOM (a -> b)
-> Resolver o e m (ResolverValue (Resolver o e m))
encodeKind (ContextValue a -> b
f) =
    forall (o :: OperationType) (m :: * -> *) e.
(LiftOperation o, Monad m) =>
Resolver o e m (Arguments VALID)
getArguments
      forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (o :: OperationType) (m :: * -> *) a e.
(LiftOperation o, Monad m) =>
ResolverState a -> Resolver o e m a
liftResolverState forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Decode a => Arguments VALID -> ResolverState a
decodeArguments
      forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) resolver.
Encode m resolver =>
resolver -> m (ResolverValue m)
encode forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f

--  GQL a -> Resolver b, MUTATION, SUBSCRIPTION, QUERY
instance
  (Monad m, Encode (Resolver o e m) b, LiftOperation o) =>
  EncodeKind CUSTOM (Resolver o e m) (Resolver o e m b)
  where
  encodeKind :: ContextValue CUSTOM (Resolver o e m b)
-> Resolver o e m (ResolverValue (Resolver o e m))
encodeKind (ContextValue Resolver o e m b
value) = Resolver o e m b
value forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) resolver.
Encode m resolver =>
resolver -> m (ResolverValue m)
encode

convertNode ::
  forall m.
  MonadError GQLError m =>
  DataType (m (ResolverValue m)) ->
  ResolverValue m
convertNode :: forall (m :: * -> *).
MonadError GQLError m =>
DataType (m (ResolverValue m)) -> ResolverValue m
convertNode
  DataType
    { TypeName
dataTypeName :: forall v. DataType v -> TypeName
dataTypeName :: TypeName
dataTypeName,
      Bool
tyIsUnion :: forall v. DataType v -> Bool
tyIsUnion :: Bool
tyIsUnion,
      tyCons :: forall v. DataType v -> ConsRep v
tyCons = cons :: ConsRep (m (ResolverValue m))
cons@ConsRep {[FieldRep (m (ResolverValue m))]
consFields :: forall v. ConsRep v -> [FieldRep v]
consFields :: [FieldRep (m (ResolverValue m))]
consFields, TypeName
consName :: forall v. ConsRep v -> TypeName
consName :: TypeName
consName}
    } = [FieldRep (m (ResolverValue m))] -> ResolverValue m
encodeTypeFields [FieldRep (m (ResolverValue m))]
consFields
    where
      -- ENUM
      encodeTypeFields ::
        [FieldRep (m (ResolverValue m))] ->
        ResolverValue m
      encodeTypeFields :: [FieldRep (m (ResolverValue m))] -> ResolverValue m
encodeTypeFields [] = forall (m :: * -> *). TypeName -> ResolverValue m
mkEnum TypeName
consName
      encodeTypeFields [FieldRep (m (ResolverValue m))]
fields
        | Bool -> Bool
not Bool
tyIsUnion = forall (m :: * -> *).
TypeName -> [ResolverEntry m] -> ResolverValue m
mkObject TypeName
dataTypeName (forall {k} (m :: k -> *) (a :: k).
FieldRep (m a) -> (FieldName, m a)
toFieldRes forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [FieldRep (m (ResolverValue m))]
fields)
      -- Type References --------------------------------------------------------------
      encodeTypeFields [FieldRep {TypeRef
fieldTypeRef :: forall a. FieldRep a -> TypeRef
fieldTypeRef :: TypeRef
fieldTypeRef, m (ResolverValue m)
fieldValue :: forall a. FieldRep a -> a
fieldValue :: m (ResolverValue m)
fieldValue}]
        | forall k. TypeName -> ConsRep k -> Bool
isUnionRef TypeName
dataTypeName ConsRep (m (ResolverValue m))
cons = forall (m :: * -> *). m (ResolverValue m) -> ResolverValue m
ResLazy (forall (m :: * -> *).
Maybe TypeName -> ObjectTypeResolver m -> ResolverValue m
ResObject (forall a. a -> Maybe a
Just (TypeRef -> TypeName
typeConName TypeRef
fieldTypeRef)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (m (ResolverValue m)
fieldValue forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (f :: * -> *) (m :: * -> *).
MonadError GQLError f =>
ResolverValue m -> f (ObjectTypeResolver m)
requireObject))
      -- Inline Union Types ----------------------------------------------------------------------------
      encodeTypeFields [FieldRep (m (ResolverValue m))]
fields = forall (m :: * -> *).
Monad m =>
TypeName -> [ResolverEntry m] -> ResolverValue m
mkUnion TypeName
consName (forall {k} (m :: k -> *) (a :: k).
FieldRep (m a) -> (FieldName, m a)
toFieldRes forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [FieldRep (m (ResolverValue m))]
fields)

-- Types & Constrains -------------------------------------------------------
class (Encode m a, GQLType a) => ExplorerConstraint m a

instance (Encode m a, GQLType a) => ExplorerConstraint m a

exploreResolvers ::
  forall m a.
  ( EncodeConstraint m a,
    MonadError GQLError m
  ) =>
  a ->
  ResolverValue m
exploreResolvers :: forall (m :: * -> *) a.
(EncodeConstraint m a, MonadError GQLError m) =>
a -> ResolverValue m
exploreResolvers =
  forall (m :: * -> *).
MonadError GQLError m =>
DataType (m (ResolverValue m)) -> ResolverValue m
convertNode
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (kind :: TypeCategory) a (constraint :: * -> Constraint)
       value.
(CategoryValue kind, Generic a,
 DeriveWith constraint value (Rep a)) =>
DeriveValueOptions kind constraint value -> a -> DataType value
deriveValue
      ( DeriveValueOptions
          { __valueApply :: forall a. ExplorerConstraint m a => a -> m (ResolverValue m)
__valueApply = forall (m :: * -> *) resolver.
Encode m resolver =>
resolver -> m (ResolverValue m)
encode,
            __valueTypeName :: TypeName
__valueTypeName = forall a (kind :: TypeCategory) (kinded :: TypeCategory -> * -> *).
(GQLType a, CategoryValue kind) =>
kinded kind a -> TypeName
deriveTypename (forall {k} {k1} (k2 :: k) (a :: k1). KindedProxy k2 a
KindedProxy :: KindedProxy IN a),
            __valueGQLOptions :: GQLTypeOptions
__valueGQLOptions = forall a (f :: * -> *).
GQLType a =>
f a -> GQLTypeOptions -> GQLTypeOptions
typeOptions (forall {k} (t :: k). Proxy t
Proxy @a) GQLTypeOptions
defaultTypeOptions,
            __valueGetType :: forall (f :: * -> *) a. ExplorerConstraint m a => f a -> TypeData
__valueGetType = forall (kinded :: TypeCategory -> * -> *) (kind :: TypeCategory) a.
(GQLType a, CategoryValue kind) =>
kinded kind a -> TypeData
__typeData forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k1} {k2} (f :: k1 -> *) (k3 :: k1) (f' :: k2 -> *)
       (a :: k2).
f k3 -> f' a -> KindedProxy k3 a
kinded (forall {k} (t :: k). Proxy t
Proxy @IN)
          } ::
          DeriveValueOptions IN (ExplorerConstraint m) (m (ResolverValue m))
      )

----- HELPERS ----------------------------
objectResolvers ::
  ( EncodeConstraint m a,
    MonadError GQLError m
  ) =>
  a ->
  ResolverState (ObjectTypeResolver m)
objectResolvers :: forall (m :: * -> *) a.
(EncodeConstraint m a, MonadError GQLError m) =>
a -> ResolverState (ObjectTypeResolver m)
objectResolvers a
value = forall (f :: * -> *) (m :: * -> *).
MonadError GQLError f =>
ResolverValue m -> f (ObjectTypeResolver m)
requireObject (forall (m :: * -> *) a.
(EncodeConstraint m a, MonadError GQLError m) =>
a -> ResolverValue m
exploreResolvers a
value)

type EncodeConstraint (m :: Type -> Type) a =
  ( GQLType a,
    Generic a,
    DeriveWith (ExplorerConstraint m) (m (ResolverValue m)) (Rep a)
  )

type EncodeObjectConstraint (o :: OperationType) e (m :: Type -> Type) a =
  EncodeConstraint (Resolver o e m) (a (Resolver o e m))

type EncodeConstraints e m query mut sub =
  ( ChannelsConstraint e m sub,
    EncodeObjectConstraint QUERY e m query,
    EncodeObjectConstraint MUTATION e m mut,
    EncodeObjectConstraint SUBSCRIPTION e m sub
  )

deriveModel ::
  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 :: 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 {query (Resolver QUERY e m)
mut (Resolver MUTATION e m)
sub (Resolver SUBSCRIPTION e m)
subscriptionResolver :: forall (m :: * -> *) event (query :: (* -> *) -> *)
       (mutation :: (* -> *) -> *) (subscription :: (* -> *) -> *).
RootResolver m event query mutation subscription
-> subscription (Resolver SUBSCRIPTION event m)
mutationResolver :: forall (m :: * -> *) event (query :: (* -> *) -> *)
       (mutation :: (* -> *) -> *) (subscription :: (* -> *) -> *).
RootResolver m event query mutation subscription
-> mutation (Resolver MUTATION event m)
queryResolver :: forall (m :: * -> *) event (query :: (* -> *) -> *)
       (mutation :: (* -> *) -> *) (subscription :: (* -> *) -> *).
RootResolver m event query mutation subscription
-> query (Resolver QUERY event m)
subscriptionResolver :: sub (Resolver SUBSCRIPTION e m)
mutationResolver :: mut (Resolver MUTATION e m)
queryResolver :: query (Resolver QUERY e m)
..} =
  forall (f :: * -> *) a. Applicative f => a -> f a
pure
    RootResolverValue
      { queryResolver :: ResolverState (ObjectTypeResolver (Resolver QUERY e m))
queryResolver = forall (m :: * -> *) a.
(EncodeConstraint m a, MonadError GQLError m) =>
a -> ResolverState (ObjectTypeResolver m)
objectResolvers query (Resolver QUERY e m)
queryResolver,
        mutationResolver :: ResolverState (ObjectTypeResolver (Resolver MUTATION e m))
mutationResolver = forall (m :: * -> *) a.
(EncodeConstraint m a, MonadError GQLError m) =>
a -> ResolverState (ObjectTypeResolver m)
objectResolvers mut (Resolver MUTATION e m)
mutationResolver,
        subscriptionResolver :: ResolverState (ObjectTypeResolver (Resolver SUBSCRIPTION e m))
subscriptionResolver = forall (m :: * -> *) a.
(EncodeConstraint m a, MonadError GQLError m) =>
a -> ResolverState (ObjectTypeResolver m)
objectResolvers sub (Resolver SUBSCRIPTION e m)
subscriptionResolver,
        Maybe (Selection VALID -> ResolverState (Channel e))
channelMap :: Maybe (Selection VALID -> ResolverState (Channel e))
channelMap :: Maybe (Selection VALID -> ResolverState (Channel e))
channelMap
      }
  where
    channelMap :: Maybe (Selection VALID -> ResolverState (Channel e))
channelMap
      | forall a (f :: * -> *). GQLType a => f a -> Bool
__isEmptyType (forall {k} (t :: k). Proxy t
Proxy :: Proxy (sub (Resolver SUBSCRIPTION e m))) = forall a. Maybe a
Nothing
      | Bool
otherwise = forall a. a -> Maybe a
Just (forall e (m :: * -> *) (subs :: (* -> *) -> *).
ChannelsConstraint e m subs =>
subs (Resolver SUBSCRIPTION e m)
-> Selection VALID -> ResolverState (Channel e)
channelResolver sub (Resolver SUBSCRIPTION e m)
subscriptionResolver)