{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE NoImplicitPrelude #-}

module Data.Morpheus.Server.Types.GQLType
  ( DeriveDirective,
    GQLType (KIND, directives, __type),
    InputTypeNamespace (..),
    deriveFingerprint,
    deriveTypename,
    encodeArguments,
    __isEmptyType,
    __typeData,
    withGQL,
    withDir,
    withDeriveType,
    DeriveType,
  )
where

-- MORPHEUS

import Control.Monad.Except (MonadError (throwError))
import Data.Morpheus.App.Internal.Resolving
  ( Resolver,
    SubscriptionField,
  )
import Data.Morpheus.Internal.Ext
import Data.Morpheus.Internal.Utils
import Data.Morpheus.Server.Deriving.Schema.DeriveKinded
import Data.Morpheus.Server.Deriving.Schema.Directive (UseDirective (..))
import Data.Morpheus.Server.Deriving.Schema.Internal
import Data.Morpheus.Server.Deriving.Utils (ConsRep (..), DataType (..), DeriveWith, FieldRep (..))
import Data.Morpheus.Server.Deriving.Utils.DeriveGType (DeriveValueOptions (..), deriveValue)
import Data.Morpheus.Server.Deriving.Utils.Kinded (KindedProxy (KindedProxy), inputType)
import Data.Morpheus.Server.Deriving.Utils.Proxy (ContextValue (..))
import Data.Morpheus.Server.Deriving.Utils.Use (UseArguments (..), UseDeriveType (..), UseGQLType (..))
import Data.Morpheus.Server.NamedResolvers (NamedResolverT (..))
import Data.Morpheus.Server.Types.Directives
  ( GDirectiveUsages (..),
    GQLDirective (..),
    applyTypeName,
    typeDirective,
  )
import Data.Morpheus.Server.Types.Internal
  ( TypeData (..),
    mkTypeData,
  )
import Data.Morpheus.Server.Types.Kind
  ( CUSTOM,
    DerivingKind,
    SCALAR,
    TYPE,
    WRAPPER,
  )
import Data.Morpheus.Server.Types.SchemaT (SchemaT, withInput)
import Data.Morpheus.Server.Types.TypeName (TypeFingerprint (..), getFingerprint, getTypename)
import Data.Morpheus.Server.Types.Types
  ( Arg,
    Pair,
    TypeGuard,
    Undefined (..),
    __typenameUndefined,
  )
import Data.Morpheus.Server.Types.Visitors (VisitType (..))
import Data.Morpheus.Types.GQLScalar (EncodeScalar (..))
import Data.Morpheus.Types.GQLWrapper (EncodeWrapperValue (..))
import Data.Morpheus.Types.ID (ID)
import Data.Morpheus.Types.Internal.AST
  ( Argument (..),
    Arguments,
    ArgumentsDefinition,
    CONST,
    DirectiveLocation (..),
    GQLError,
    IN,
    OUT,
    ObjectEntry (..),
    Position (..),
    TypeCategory (..),
    TypeName,
    TypeWrapper (..),
    Value (..),
    internal,
    mkBaseType,
    toNullable,
    unitTypeName,
  )
import Data.Sequence (Seq)
import Data.Vector (Vector)
import GHC.Generics
import GHC.TypeLits (KnownSymbol)
import Relude hiding (Seq, Undefined, fromList, intercalate)

__isEmptyType :: forall f a. GQLType a => f a -> Bool
__isEmptyType :: forall (f :: * -> *) a. GQLType a => f a -> Bool
__isEmptyType f a
_ = forall a (cat :: TypeCategory).
GQLType a =>
CatType cat a -> TypeFingerprint
deriveFingerprint (forall {k} (a :: k). CatType OUT a
OutputType :: CatType OUT a) forall a. Eq a => a -> a -> Bool
== TypeName -> TypeFingerprint
InternalFingerprint TypeName
__typenameUndefined

__typeData :: (GQLType a) => CatType cat a -> TypeData
__typeData :: forall a (cat :: TypeCategory).
GQLType a =>
CatType cat a -> TypeData
__typeData proxy :: CatType cat a
proxy@CatType cat a
InputType = forall a (f :: * -> *).
GQLType a =>
f a -> TypeCategory -> TypeData
__type CatType cat a
proxy TypeCategory
IN
__typeData proxy :: CatType cat a
proxy@CatType cat a
OutputType = forall a (f :: * -> *).
GQLType a =>
f a -> TypeCategory -> TypeData
__type CatType cat a
proxy TypeCategory
OUT

deriveTypename :: (GQLType a) => CatType cat a -> TypeName
deriveTypename :: forall a (cat :: TypeCategory).
GQLType a =>
CatType cat a -> TypeName
deriveTypename CatType cat a
proxy = TypeData -> TypeName
gqlTypeName forall a b. (a -> b) -> a -> b
$ forall a (cat :: TypeCategory).
GQLType a =>
CatType cat a -> TypeData
__typeData CatType cat a
proxy

deriveFingerprint :: (GQLType a) => CatType cat a -> TypeFingerprint
deriveFingerprint :: forall a (cat :: TypeCategory).
GQLType a =>
CatType cat a -> TypeFingerprint
deriveFingerprint CatType cat a
proxy = TypeData -> TypeFingerprint
gqlFingerprint forall a b. (a -> b) -> a -> b
$ forall a (cat :: TypeCategory).
GQLType a =>
CatType cat a -> TypeData
__typeData CatType cat a
proxy

deriveTypeData ::
  Typeable a =>
  f a ->
  DirectiveUsages ->
  TypeCategory ->
  TypeData
deriveTypeData :: forall a (f :: * -> *).
Typeable a =>
f a -> DirectiveUsages -> TypeCategory -> TypeData
deriveTypeData f a
proxy GDirectiveUsages {[GDirectiveUsage GQLType DeriveDirective]
typeDirectives :: forall (gql :: * -> Constraint) (args :: * -> Constraint).
GDirectiveUsages gql args -> [GDirectiveUsage gql args]
typeDirectives :: [GDirectiveUsage GQLType DeriveDirective]
typeDirectives} TypeCategory
cat =
  TypeData
    { gqlTypeName :: TypeName
gqlTypeName = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (forall (gql :: * -> Constraint) (args :: * -> Constraint).
GDirectiveUsage gql args -> Bool -> TypeName -> TypeName
`applyTypeName` (TypeCategory
cat forall a. Eq a => a -> a -> Bool
== TypeCategory
IN)) (forall a (f :: * -> *). Typeable a => f a -> TypeName
getTypename f a
proxy) [GDirectiveUsage GQLType DeriveDirective]
typeDirectives,
      gqlWrappers :: TypeWrapper
gqlWrappers = TypeWrapper
mkBaseType,
      gqlFingerprint :: TypeFingerprint
gqlFingerprint = forall a (f :: * -> *).
Typeable a =>
TypeCategory -> f a -> TypeFingerprint
getFingerprint TypeCategory
cat f a
proxy
    }

list :: TypeWrapper -> TypeWrapper
list :: TypeWrapper -> TypeWrapper
list = forall a b c. (a -> b -> c) -> b -> a -> c
flip TypeWrapper -> Bool -> TypeWrapper
TypeList Bool
True

wrapper :: (TypeWrapper -> TypeWrapper) -> TypeData -> TypeData
wrapper :: (TypeWrapper -> TypeWrapper) -> TypeData -> TypeData
wrapper TypeWrapper -> TypeWrapper
f TypeData {TypeWrapper
TypeName
TypeFingerprint
gqlFingerprint :: TypeFingerprint
gqlWrappers :: TypeWrapper
gqlTypeName :: TypeName
gqlWrappers :: TypeData -> TypeWrapper
gqlFingerprint :: TypeData -> TypeFingerprint
gqlTypeName :: TypeData -> TypeName
..} = TypeData {gqlWrappers :: TypeWrapper
gqlWrappers = TypeWrapper -> TypeWrapper
f TypeWrapper
gqlWrappers, TypeName
TypeFingerprint
gqlFingerprint :: TypeFingerprint
gqlTypeName :: TypeName
gqlFingerprint :: TypeFingerprint
gqlTypeName :: TypeName
..}

-- | GraphQL type, every graphQL type should have an instance of 'GHC.Generics.Generic' and 'GQLType'.
--
--  @
--    ... deriving (Generic, GQLType)
--  @
--
-- if you want to add description
--
--  @
--       ... deriving (Generic)
--
--     instance GQLType ... where
--        directives _ = typeDirective (Describe "some text")
--  @
class GQLType a where
  type KIND a :: DerivingKind
  type KIND a = TYPE

  directives :: f a -> DirectiveUsages
  directives f a
_ = forall a. Monoid a => a
mempty

  __type :: f a -> TypeCategory -> TypeData
  default __type :: Typeable a => f a -> TypeCategory -> TypeData
  __type f a
proxy = forall a (f :: * -> *).
Typeable a =>
f a -> DirectiveUsages -> TypeCategory -> TypeData
deriveTypeData f a
proxy (forall a (f :: * -> *). GQLType a => f a -> DirectiveUsages
directives f a
proxy)

instance GQLType Int where
  type KIND Int = SCALAR
  __type :: forall (f :: * -> *). f Int -> TypeCategory -> TypeData
__type f Int
_ = forall a. TypeName -> a -> TypeData
mkTypeData TypeName
"Int"

instance GQLType Double where
  type KIND Double = SCALAR
  __type :: forall (f :: * -> *). f Double -> TypeCategory -> TypeData
__type f Double
_ = forall a. TypeName -> a -> TypeData
mkTypeData TypeName
"Float"

instance GQLType Float where
  type KIND Float = SCALAR
  __type :: forall (f :: * -> *). f Float -> TypeCategory -> TypeData
__type f Float
_ = forall a. TypeName -> a -> TypeData
mkTypeData TypeName
"Float32"

instance GQLType Text where
  type KIND Text = SCALAR
  __type :: forall (f :: * -> *). f Text -> TypeCategory -> TypeData
__type f Text
_ = forall a. TypeName -> a -> TypeData
mkTypeData TypeName
"String"

instance GQLType Bool where
  type KIND Bool = SCALAR
  __type :: forall (f :: * -> *). f Bool -> TypeCategory -> TypeData
__type f Bool
_ = forall a. TypeName -> a -> TypeData
mkTypeData TypeName
"Boolean"

instance GQLType ID where
  type KIND ID = SCALAR
  __type :: forall (f :: * -> *). f ID -> TypeCategory -> TypeData
__type f ID
_ = forall a. TypeName -> a -> TypeData
mkTypeData TypeName
"ID"

instance GQLType (Value CONST) where
  type KIND (Value CONST) = CUSTOM
  __type :: forall (f :: * -> *). f (Value CONST) -> TypeCategory -> TypeData
__type f (Value CONST)
_ = forall a. TypeName -> a -> TypeData
mkTypeData TypeName
"INTERNAL_VALUE"

-- WRAPPERS
instance GQLType () where
  __type :: forall (f :: * -> *). f () -> TypeCategory -> TypeData
__type f ()
_ = forall a. TypeName -> a -> TypeData
mkTypeData TypeName
unitTypeName

instance Typeable m => GQLType (Undefined m) where
  type KIND (Undefined m) = CUSTOM
  __type :: forall (f :: * -> *). f (Undefined m) -> TypeCategory -> TypeData
__type f (Undefined m)
_ = forall a. TypeName -> a -> TypeData
mkTypeData TypeName
__typenameUndefined

instance GQLType a => GQLType (Maybe a) where
  type KIND (Maybe a) = WRAPPER
  __type :: forall (f :: * -> *). f (Maybe a) -> TypeCategory -> TypeData
__type f (Maybe a)
_ = (TypeWrapper -> TypeWrapper) -> TypeData -> TypeData
wrapper forall a. Nullable a => a -> a
toNullable forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a (f :: * -> *).
GQLType a =>
f a -> TypeCategory -> TypeData
__type (forall {k} (t :: k). Proxy t
Proxy @a)

instance GQLType a => GQLType [a] where
  type KIND [a] = WRAPPER
  __type :: forall (f :: * -> *). f [a] -> TypeCategory -> TypeData
__type f [a]
_ = (TypeWrapper -> TypeWrapper) -> TypeData -> TypeData
wrapper TypeWrapper -> TypeWrapper
list forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a (f :: * -> *).
GQLType a =>
f a -> TypeCategory -> TypeData
__type (forall {k} (t :: k). Proxy t
Proxy @a)

instance GQLType a => GQLType (Set a) where
  type KIND (Set a) = WRAPPER
  __type :: forall (f :: * -> *). f (Set a) -> TypeCategory -> TypeData
__type f (Set a)
_ = forall a (f :: * -> *).
GQLType a =>
f a -> TypeCategory -> TypeData
__type forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k). Proxy t
Proxy @[a]

instance GQLType a => GQLType (NonEmpty a) where
  type KIND (NonEmpty a) = WRAPPER
  __type :: forall (f :: * -> *). f (NonEmpty a) -> TypeCategory -> TypeData
__type f (NonEmpty a)
_ = forall a (f :: * -> *).
GQLType a =>
f a -> TypeCategory -> TypeData
__type forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k). Proxy t
Proxy @[a]

instance GQLType a => GQLType (Seq a) where
  type KIND (Seq a) = WRAPPER
  __type :: forall (f :: * -> *). f (Seq a) -> TypeCategory -> TypeData
__type f (Seq a)
_ = forall a (f :: * -> *).
GQLType a =>
f a -> TypeCategory -> TypeData
__type forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k). Proxy t
Proxy @[a]

instance GQLType a => GQLType (Vector a) where
  type KIND (Vector a) = WRAPPER
  __type :: forall (f :: * -> *). f (Vector a) -> TypeCategory -> TypeData
__type f (Vector a)
_ = forall a (f :: * -> *).
GQLType a =>
f a -> TypeCategory -> TypeData
__type forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k). Proxy t
Proxy @[a]

instance GQLType a => GQLType (SubscriptionField a) where
  type KIND (SubscriptionField a) = WRAPPER
  __type :: forall (f :: * -> *).
f (SubscriptionField a) -> TypeCategory -> TypeData
__type f (SubscriptionField a)
_ = forall a (f :: * -> *).
GQLType a =>
f a -> TypeCategory -> TypeData
__type forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k). Proxy t
Proxy @a

instance (Typeable a, Typeable b, GQLType a, GQLType b) => GQLType (Pair a b) where
  directives :: forall (f :: * -> *). f (Pair a b) -> DirectiveUsages
directives f (Pair a b)
_ = forall a (gql :: * -> Constraint) (args :: * -> Constraint).
(GQLDirective a, gql a, args a) =>
a -> GDirectiveUsages gql args
typeDirective InputTypeNamespace {inputTypeNamespace :: Text
inputTypeNamespace = Text
"Input"}

-- Manual

instance GQLType b => GQLType (a -> b) where
  type KIND (a -> b) = CUSTOM
  __type :: forall (f :: * -> *). f (a -> b) -> TypeCategory -> TypeData
__type f (a -> b)
_ = forall a (f :: * -> *).
GQLType a =>
f a -> TypeCategory -> TypeData
__type forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k). Proxy t
Proxy @b

instance (GQLType k, GQLType v, Typeable k, Typeable v) => GQLType (Map k v) where
  type KIND (Map k v) = CUSTOM
  __type :: forall (f :: * -> *). f (Map k v) -> TypeCategory -> TypeData
__type f (Map k v)
_ = forall a (f :: * -> *).
GQLType a =>
f a -> TypeCategory -> TypeData
__type forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k). Proxy t
Proxy @[Pair k v]

instance GQLType a => GQLType (Resolver o e m a) where
  type KIND (Resolver o e m a) = CUSTOM
  __type :: forall (f :: * -> *).
f (Resolver o e m a) -> TypeCategory -> TypeData
__type f (Resolver o e m a)
_ = forall a (f :: * -> *).
GQLType a =>
f a -> TypeCategory -> TypeData
__type forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k). Proxy t
Proxy @a

instance (Typeable a, Typeable b, GQLType a, GQLType b) => GQLType (a, b) where
  __type :: forall (f :: * -> *). f (a, b) -> TypeCategory -> TypeData
__type f (a, b)
_ = forall a (f :: * -> *).
GQLType a =>
f a -> TypeCategory -> TypeData
__type forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k). Proxy t
Proxy @(Pair a b)
  directives :: forall (f :: * -> *). f (a, b) -> DirectiveUsages
directives f (a, b)
_ = forall a (gql :: * -> Constraint) (args :: * -> Constraint).
(GQLDirective a, gql a, args a) =>
a -> GDirectiveUsages gql args
typeDirective InputTypeNamespace {inputTypeNamespace :: Text
inputTypeNamespace = Text
"Input"}

instance (GQLType value) => GQLType (Arg name value) where
  type KIND (Arg name value) = CUSTOM
  __type :: forall (f :: * -> *).
f (Arg name value) -> TypeCategory -> TypeData
__type f (Arg name value)
_ = forall a (f :: * -> *).
GQLType a =>
f a -> TypeCategory -> TypeData
__type (forall {k} (t :: k). Proxy t
Proxy @value)

instance (GQLType interface) => GQLType (TypeGuard interface possibleTypes) where
  type KIND (TypeGuard interface possibleTypes) = CUSTOM
  __type :: forall (f :: * -> *).
f (TypeGuard interface possibleTypes) -> TypeCategory -> TypeData
__type f (TypeGuard interface possibleTypes)
_ = forall a (f :: * -> *).
GQLType a =>
f a -> TypeCategory -> TypeData
__type (forall {k} (t :: k). Proxy t
Proxy @interface)

instance (GQLType a) => GQLType (Proxy a) where
  type KIND (Proxy a) = KIND a
  __type :: forall (f :: * -> *). f (Proxy a) -> TypeCategory -> TypeData
__type f (Proxy a)
_ = forall a (f :: * -> *).
GQLType a =>
f a -> TypeCategory -> TypeData
__type (forall {k} (t :: k). Proxy t
Proxy @a)

instance (GQLType a) => GQLType (NamedResolverT m a) where
  type KIND (NamedResolverT m a) = CUSTOM
  __type :: forall (f :: * -> *).
f (NamedResolverT m a) -> TypeCategory -> TypeData
__type f (NamedResolverT m a)
_ = forall a (f :: * -> *).
GQLType a =>
f a -> TypeCategory -> TypeData
__type (forall {k} (t :: k). Proxy t
Proxy :: Proxy a)

type EncodeValue a = EncodeKind (KIND a) a

encodeArguments :: forall m a. (MonadError GQLError m, EncodeValue a) => a -> m (Arguments CONST)
encodeArguments :: forall (m :: * -> *) a.
(MonadError GQLError m, EncodeValue a) =>
a -> m (Arguments CONST)
encodeArguments a
x = forall err a' a.
(NonEmpty err -> a') -> (a -> a') -> Result err a -> a'
resultOr (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError GQLError
err) forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. EncodeValue a => a -> GQLResult (Value CONST)
encode a
x) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall {f :: * -> *} {valid :: Stage}.
MonadError GQLError f =>
Value valid -> f (OrdMap FieldName (Argument valid))
unpackValue
  where
    err :: GQLError
err = GQLError -> GQLError
internal GQLError
"could not encode arguments. Arguments should be an object like type!"
    unpackValue :: Value valid -> f (OrdMap FieldName (Argument valid))
unpackValue (Object Object valid
v) = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall {valid :: Stage}. ObjectEntry valid -> Argument valid
toArgument Object valid
v
    unpackValue Value valid
_ = forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError GQLError
err
    toArgument :: ObjectEntry valid -> Argument valid
toArgument ObjectEntry {Value valid
FieldName
entryName :: forall (s :: Stage). ObjectEntry s -> FieldName
entryValue :: forall (s :: Stage). ObjectEntry s -> Value s
entryValue :: Value valid
entryName :: FieldName
..} = forall (valid :: Stage).
Position -> FieldName -> Value valid -> Argument valid
Argument (Int -> Int -> Position
Position Int
0 Int
0) FieldName
entryName Value valid
entryValue

encode :: forall a. EncodeValue a => a -> GQLResult (Value CONST)
encode :: forall a. EncodeValue a => a -> GQLResult (Value CONST)
encode a
x = forall (kind :: DerivingKind) a.
EncodeKind kind a =>
ContextValue kind a -> GQLResult (Value CONST)
encodeKind (forall (kind :: DerivingKind) a. a -> ContextValue kind a
ContextValue a
x :: ContextValue (KIND a) a)

class EncodeKind (kind :: DerivingKind) (a :: Type) where
  encodeKind :: ContextValue kind a -> GQLResult (Value CONST)

instance (EncodeWrapperValue f, EncodeValue a) => EncodeKind WRAPPER (f a) where
  encodeKind :: ContextValue WRAPPER (f a) -> GQLResult (Value CONST)
encodeKind = forall (f :: * -> *) (m :: * -> *) a.
(EncodeWrapperValue f, Monad m) =>
(a -> m (Value CONST)) -> f a -> m (Value CONST)
encodeWrapperValue forall a. EncodeValue a => a -> GQLResult (Value CONST)
encode forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (kind :: DerivingKind) a. ContextValue kind a -> a
unContextValue

instance (EncodeScalar a) => EncodeKind SCALAR a where
  encodeKind :: ContextValue SCALAR a -> GQLResult (Value CONST)
encodeKind = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (stage :: Stage). ScalarValue -> Value stage
Scalar 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 a) => EncodeKind TYPE a where
  encodeKind :: ContextValue TYPE a -> GQLResult (Value CONST)
encodeKind = forall a. EncodeConstraint a => a -> GQLResult (Value CONST)
exploreResolvers forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (kind :: DerivingKind) a. ContextValue kind a -> a
unContextValue

instance EncodeKind CUSTOM (Value CONST) where
  encodeKind :: ContextValue CUSTOM (Value CONST) -> GQLResult (Value CONST)
encodeKind = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (kind :: DerivingKind) a. ContextValue kind a -> a
unContextValue

-- TODO: remove me
instance (KnownSymbol name) => EncodeKind CUSTOM (Arg name a) where
  encodeKind :: ContextValue CUSTOM (Arg name a) -> GQLResult (Value CONST)
encodeKind ContextValue CUSTOM (Arg name a)
_ = forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError GQLError
"directives cant be tagged arguments"

convertNode ::
  DataType (GQLResult (Value CONST)) ->
  GQLResult (Value CONST)
convertNode :: DataType (GQLResult (Value CONST)) -> GQLResult (Value CONST)
convertNode
  DataType
    { Bool
tyIsUnion :: forall v. DataType v -> Bool
tyIsUnion :: Bool
tyIsUnion,
      tyCons :: forall v. DataType v -> ConsRep v
tyCons = ConsRep {[FieldRep (GQLResult (Value CONST))]
consFields :: forall v. ConsRep v -> [FieldRep v]
consFields :: [FieldRep (GQLResult (Value CONST))]
consFields, TypeName
consName :: forall v. ConsRep v -> TypeName
consName :: TypeName
consName}
    } = [FieldRep (GQLResult (Value CONST))] -> GQLResult (Value CONST)
encodeTypeFields [FieldRep (GQLResult (Value CONST))]
consFields
    where
      encodeTypeFields ::
        [FieldRep (GQLResult (Value CONST))] -> GQLResult (Value CONST)
      encodeTypeFields :: [FieldRep (GQLResult (Value CONST))] -> GQLResult (Value CONST)
encodeTypeFields [] = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (stage :: Stage). TypeName -> Value stage
Enum TypeName
consName
      encodeTypeFields [FieldRep (GQLResult (Value CONST))]
fields | Bool -> Bool
not Bool
tyIsUnion = forall (stage :: Stage). Object stage -> Value stage
Object forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall {m :: * -> *} {s :: Stage}.
Monad m =>
FieldRep (m (Value s)) -> m (ObjectEntry s)
fromField [FieldRep (GQLResult (Value CONST))]
fields forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) k a (map :: * -> * -> *).
(Monad m, KeyOf k a, FromList m map k a) =>
[a] -> m (map k a)
fromElems)
        where
          fromField :: FieldRep (m (Value s)) -> m (ObjectEntry s)
fromField FieldRep {FieldName
fieldSelector :: forall a. FieldRep a -> FieldName
fieldSelector :: FieldName
fieldSelector, m (Value s)
fieldValue :: forall a. FieldRep a -> a
fieldValue :: m (Value s)
fieldValue} = do
            Value s
entryValue <- m (Value s)
fieldValue
            forall (f :: * -> *) a. Applicative f => a -> f a
pure ObjectEntry {entryName :: FieldName
entryName = FieldName
fieldSelector, Value s
entryValue :: Value s
entryValue :: Value s
entryValue}
      -- Type References --------------------------------------------------------------
      encodeTypeFields [FieldRep (GQLResult (Value CONST))]
_ = forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (GQLError -> GQLError
internal GQLError
"input unions are not supported")

-- Types & Constrains -------------------------------------------------------
class (EncodeKind (KIND a) a) => ExplorerConstraint a

instance (EncodeKind (KIND a) a) => ExplorerConstraint a

exploreResolvers :: forall a. EncodeConstraint a => a -> GQLResult (Value CONST)
exploreResolvers :: forall a. EncodeConstraint a => a -> GQLResult (Value CONST)
exploreResolvers =
  DataType (GQLResult (Value CONST)) -> GQLResult (Value CONST)
convertNode
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} a (gql :: * -> Constraint)
       (constraint :: * -> Constraint) value (kind :: k).
(Generic a, DeriveWith gql constraint value (Rep a)) =>
DeriveValueOptions kind gql constraint value -> a -> DataType value
deriveValue
      ( DeriveValueOptions
          { __valueApply :: forall a. ExplorerConstraint a => a -> GQLResult (Value CONST)
__valueApply = forall a. EncodeValue a => a -> GQLResult (Value CONST)
encode,
            __valueTypeName :: TypeName
__valueTypeName = forall a (cat :: TypeCategory).
GQLType a =>
CatType cat a -> TypeName
deriveTypename (forall {k} (a :: k). CatType 'IN a
InputType :: CatType IN a),
            __valueGetType :: forall (f :: * -> *) a. GQLType a => f a -> TypeData
__valueGetType = forall a (cat :: TypeCategory).
GQLType a =>
CatType cat a -> TypeData
__typeData forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (f :: k -> *) (a :: k). f a -> CatType 'IN a
inputType
          } ::
          DeriveValueOptions IN GQLType ExplorerConstraint (GQLResult (Value CONST))
      )

type EncodeConstraint a =
  ( Generic a,
    GQLType a,
    DeriveWith GQLType ExplorerConstraint (GQLResult (Value CONST)) (Rep a)
  )

-- DIRECTIVES
type DeriveArguments a = DeriveArgs GQLType DeriveType (KIND a) a

type DirectiveUsages = GDirectiveUsages GQLType DeriveDirective

deriveArguments :: DeriveArgs GQLType DeriveType k a => f k a -> SchemaT OUT (ArgumentsDefinition CONST)
deriveArguments :: forall (k :: DerivingKind) a (f :: DerivingKind -> * -> *).
DeriveArgs GQLType DeriveType k a =>
f k a -> SchemaT OUT (ArgumentsDefinition CONST)
deriveArguments = forall a. SchemaT 'IN a -> SchemaT OUT a
withInput forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (gql :: * -> Constraint)
       (derive :: TypeCategory -> * -> Constraint) (k :: DerivingKind)
       (a :: k) (dir :: * -> Constraint) (f :: DerivingKind -> k -> *).
DeriveArgs gql derive k a =>
UseDirective gql dir
-> UseDeriveType derive
-> f k a
-> SchemaT 'IN (ArgumentsDefinition CONST)
deriveArgs UseDirective GQLType DeriveDirective
withDir UseDeriveType DeriveType
withDeriveType

class (EncodeValue a, DeriveArguments a) => DeriveDirective a

instance (EncodeValue a, DeriveArguments a) => DeriveDirective a

newtype InputTypeNamespace = InputTypeNamespace {InputTypeNamespace -> Text
inputTypeNamespace :: Text}
  deriving (forall x. Rep InputTypeNamespace x -> InputTypeNamespace
forall x. InputTypeNamespace -> Rep InputTypeNamespace x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep InputTypeNamespace x -> InputTypeNamespace
$cfrom :: forall x. InputTypeNamespace -> Rep InputTypeNamespace x
Generic)
  deriving anyclass
    (forall a.
(forall (f :: * -> *). f a -> DirectiveUsages)
-> (forall (f :: * -> *). f a -> TypeCategory -> TypeData)
-> GQLType a
forall (f :: * -> *). f InputTypeNamespace -> DirectiveUsages
forall (f :: * -> *).
f InputTypeNamespace -> TypeCategory -> TypeData
__type :: forall (f :: * -> *).
f InputTypeNamespace -> TypeCategory -> TypeData
$c__type :: forall (f :: * -> *).
f InputTypeNamespace -> TypeCategory -> TypeData
directives :: forall (f :: * -> *). f InputTypeNamespace -> DirectiveUsages
$cdirectives :: forall (f :: * -> *). f InputTypeNamespace -> DirectiveUsages
GQLType)

instance GQLDirective InputTypeNamespace where
  excludeFromSchema :: forall (f :: * -> *). f InputTypeNamespace -> Bool
excludeFromSchema f InputTypeNamespace
_ = Bool
True
  type
    DIRECTIVE_LOCATIONS InputTypeNamespace =
      '[ 'LOCATION_OBJECT,
         'LOCATION_ENUM,
         'LOCATION_INPUT_OBJECT,
         'LOCATION_UNION,
         'LOCATION_SCALAR,
         'LOCATION_INTERFACE
       ]

instance VisitType InputTypeNamespace where
  visitTypeName :: InputTypeNamespace -> Bool -> Text -> Text
visitTypeName InputTypeNamespace {Text
inputTypeNamespace :: Text
inputTypeNamespace :: InputTypeNamespace -> Text
inputTypeNamespace} Bool
isInput Text
name
    | Bool
isInput = Text
inputTypeNamespace forall a. Semigroup a => a -> a -> a
<> Text
name
    | Bool
otherwise = Text
name

withArgs :: UseArguments DeriveDirective
withArgs :: UseArguments DeriveDirective
withArgs =
  UseArguments
    { useDeriveArguments :: forall (f :: * -> *) a.
DeriveDirective a =>
f a -> SchemaT OUT (ArgumentsDefinition CONST)
useDeriveArguments = forall (k :: DerivingKind) a (f :: DerivingKind -> * -> *).
DeriveArgs GQLType DeriveType k a =>
f k a -> SchemaT OUT (ArgumentsDefinition CONST)
deriveArguments forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. f a -> KindedProxy (KIND a) a
withKind,
      useEncodeArguments :: forall (k :: TypeCategory) a.
DeriveDirective a =>
a -> SchemaT k (Arguments CONST)
useEncodeArguments = forall (m :: * -> *) a.
(MonadError GQLError m, EncodeValue a) =>
a -> m (Arguments CONST)
encodeArguments
    }

withGQL :: UseGQLType GQLType
withGQL :: UseGQLType GQLType
withGQL =
  UseGQLType
    { __useFingerprint :: forall (f :: * -> *) a.
GQLType a =>
TypeCategory -> f a -> TypeFingerprint
__useFingerprint = \TypeCategory
c f a
v -> TypeData -> TypeFingerprint
gqlFingerprint (forall a (f :: * -> *).
GQLType a =>
f a -> TypeCategory -> TypeData
__type f a
v TypeCategory
c),
      __useTypename :: forall (f :: * -> *) a.
GQLType a =>
TypeCategory -> f a -> TypeName
__useTypename = \TypeCategory
c f a
v -> TypeData -> TypeName
gqlTypeName (forall a (f :: * -> *).
GQLType a =>
f a -> TypeCategory -> TypeData
__type f a
v TypeCategory
c),
      __useTypeData :: forall (f :: * -> *) a.
GQLType a =>
f a -> TypeCategory -> TypeData
__useTypeData = forall a (f :: * -> *).
GQLType a =>
f a -> TypeCategory -> TypeData
__type
    }

withDir :: UseDirective GQLType DeriveDirective
withDir :: UseDirective GQLType DeriveDirective
withDir =
  UseDirective
    { __directives :: forall (f :: * -> *) a. GQLType a => f a -> DirectiveUsages
__directives = forall a (f :: * -> *). GQLType a => f a -> DirectiveUsages
directives,
      dirGQL :: UseGQLType GQLType
dirGQL = UseGQLType GQLType
withGQL,
      dirArgs :: UseArguments DeriveDirective
dirArgs = UseArguments DeriveDirective
withArgs
    }

withKind :: f a -> KindedProxy (KIND a) a
withKind :: forall (f :: * -> *) a. f a -> KindedProxy (KIND a) a
withKind f a
_ = forall {k} {k} (k :: k) (a :: k). KindedProxy k a
KindedProxy

withDeriveType :: UseDeriveType DeriveType
withDeriveType :: UseDeriveType DeriveType
withDeriveType =
  UseDeriveType
    { useDeriveType :: forall (c :: TypeCategory) a.
DeriveType c a =>
CatType c a -> SchemaT c ()
useDeriveType = forall (c :: TypeCategory) a.
DeriveType c a =>
CatType c a -> SchemaT c ()
deriveType,
      useDeriveContent :: forall (c :: TypeCategory) a.
DeriveType c a =>
CatType c a -> TyContentM c
useDeriveContent = forall (c :: TypeCategory) a.
DeriveType c a =>
CatType c a -> TyContentM c
deriveContent
    }

-- DERIVE TYPE

-- |  Generates internal GraphQL Schema for query validation and introspection rendering
class DeriveType (c :: TypeCategory) (a :: Type) where
  deriveType :: CatType c a -> SchemaT c ()
  deriveContent :: CatType c a -> TyContentM c

instance (GQLType a, DeriveKindedType GQLType DeriveType DeriveDirective cat (KIND a) a) => DeriveType cat a where
  deriveType :: CatType cat a -> SchemaT cat ()
deriveType = forall {k} (gql :: * -> Constraint)
       (derive :: TypeCategory -> * -> Constraint)
       (dir :: * -> Constraint) (cat :: TypeCategory)
       (kind :: DerivingKind) (a :: k) {k} (f :: DerivingKind -> k -> k).
DeriveKindedType gql derive dir cat kind a =>
UseDirective gql dir
-> UseDeriveType derive -> CatType cat (f kind a) -> SchemaT cat ()
deriveKindedType UseDirective GQLType DeriveDirective
withDir UseDeriveType DeriveType
withDeriveType forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (cat :: TypeCategory) a (f :: DerivingKind -> * -> *).
CatType cat a -> CatType cat (f (KIND a) a)
liftKind
  deriveContent :: CatType cat a -> TyContentM cat
deriveContent = forall {k} (gql :: * -> Constraint)
       (derive :: TypeCategory -> * -> Constraint)
       (dir :: * -> Constraint) (cat :: TypeCategory)
       (kind :: DerivingKind) (a :: k) {k} (f :: DerivingKind -> k -> k).
DeriveKindedType gql derive dir cat kind a =>
UseDirective gql dir
-> UseDeriveType derive -> CatType cat (f kind a) -> TyContentM cat
deriveKindedContent UseDirective GQLType DeriveDirective
withDir UseDeriveType DeriveType
withDeriveType forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (cat :: TypeCategory) a (f :: DerivingKind -> * -> *).
CatType cat a -> CatType cat (f (KIND a) a)
liftKind

liftKind :: CatType cat a -> CatType cat (f (KIND a) a)
liftKind :: forall (cat :: TypeCategory) a (f :: DerivingKind -> * -> *).
CatType cat a -> CatType cat (f (KIND a) a)
liftKind CatType cat a
InputType = forall {k} (a :: k). CatType 'IN a
InputType
liftKind CatType cat a
OutputType = forall {k} (a :: k). CatType OUT a
OutputType