{-# 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
  ( GQLType (KIND, directives, __type),
    __typeData,
    deriveTypename,
    deriveFingerprint,
    encodeArguments,
    DirectiveUsage (..),
    DeriveArguments (..),
    DirectiveUsages (..),
    typeDirective,
    fieldDirective,
    fieldDirective',
    enumDirective,
    enumDirective',
    applyTypeName,
    applyTypeDescription,
    applyEnumName,
    applyEnumDescription,
    applyFieldName,
    applyFieldDescription,
    applyFieldDefaultValue,
    applyTypeFieldNames,
    applyTypeEnumNames,
    __isEmptyType,
    InputTypeNamespace (..),
  )
where

-- MORPHEUS

import Control.Monad.Except (MonadError (throwError))
import qualified Data.HashMap.Strict as M
import Data.Morpheus.App.Internal.Resolving
  ( Resolver,
    SubscriptionField,
  )
import Data.Morpheus.Internal.Ext
import Data.Morpheus.Internal.Utils
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 (CategoryValue (..), KindedProxy (KindedProxy), kinded)
import Data.Morpheus.Server.Deriving.Utils.Proxy (ContextValue (..))
import Data.Morpheus.Server.NamedResolvers (NamedResolverT (..))
import Data.Morpheus.Server.Types.Directives
  ( GQLDirective (..),
    ToLocations (..),
    visitEnumDescription',
    visitEnumName',
    visitEnumNames',
    visitFieldDefaultValue',
    visitFieldDescription',
    visitFieldName',
    visitFieldNames',
    visitTypeDescription',
    visitTypeName',
  )
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)
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,
    Description,
    DirectiveLocation (..),
    FieldName,
    GQLError,
    IN,
    OUT,
    ObjectEntry (..),
    Position (..),
    TypeCategory (..),
    TypeName,
    TypeWrapper (..),
    Value (..),
    internal,
    mkBaseType,
    packName,
    toNullable,
    unitTypeName,
  )
import Data.Sequence (Seq)
import Data.Vector (Vector)
import GHC.Generics
import qualified Language.Haskell.TH.Syntax as TH
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 (kind :: TypeCategory) (kinded :: TypeCategory -> * -> *).
(GQLType a, CategoryValue kind) =>
kinded kind a -> TypeFingerprint
deriveFingerprint (forall {k} {k} (k :: k) (a :: k). KindedProxy k a
KindedProxy :: KindedProxy OUT a) forall a. Eq a => a -> a -> Bool
== TypeName -> TypeFingerprint
InternalFingerprint TypeName
__typenameUndefined

__typeData ::
  forall kinded (kind :: TypeCategory) (a :: Type).
  (GQLType a, CategoryValue kind) =>
  kinded kind a ->
  TypeData
__typeData :: forall (kinded :: TypeCategory -> * -> *) (kind :: TypeCategory) a.
(GQLType a, CategoryValue kind) =>
kinded kind a -> TypeData
__typeData kinded kind a
proxy = forall a (f :: * -> *).
GQLType a =>
f a -> TypeCategory -> TypeData
__type kinded kind a
proxy (forall (c :: TypeCategory) (f :: TypeCategory -> *).
CategoryValue c =>
f c -> TypeCategory
categoryValue (forall {k} (t :: k). Proxy t
Proxy @kind))

deriveTypename :: (GQLType a, CategoryValue kind) => kinded kind a -> TypeName
deriveTypename :: forall a (kind :: TypeCategory) (kinded :: TypeCategory -> * -> *).
(GQLType a, CategoryValue kind) =>
kinded kind a -> TypeName
deriveTypename kinded kind a
proxy = TypeData -> TypeName
gqlTypeName forall a b. (a -> b) -> a -> b
$ forall (kinded :: TypeCategory -> * -> *) (kind :: TypeCategory) a.
(GQLType a, CategoryValue kind) =>
kinded kind a -> TypeData
__typeData kinded kind a
proxy

deriveFingerprint :: (GQLType a, CategoryValue kind) => kinded kind a -> TypeFingerprint
deriveFingerprint :: forall a (kind :: TypeCategory) (kinded :: TypeCategory -> * -> *).
(GQLType a, CategoryValue kind) =>
kinded kind a -> TypeFingerprint
deriveFingerprint kinded kind a
proxy = TypeData -> TypeFingerprint
gqlFingerprint forall a b. (a -> b) -> a -> b
$ forall (kinded :: TypeCategory -> * -> *) (kind :: TypeCategory) a.
(GQLType a, CategoryValue kind) =>
kinded kind a -> TypeData
__typeData kinded kind 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 DirectiveUsages {[DirectiveUsage]
typeDirectives :: DirectiveUsages -> [DirectiveUsage]
typeDirectives :: [DirectiveUsage]
typeDirectives} TypeCategory
cat =
  TypeData
    { gqlTypeName :: TypeName
gqlTypeName = Bool -> TypeName -> [DirectiveUsage] -> TypeName
typeNameWithDirectives (TypeCategory
cat forall a. Eq a => a -> a -> Bool
== TypeCategory
IN) (forall a (f :: * -> *). Typeable a => f a -> TypeName
getTypename f a
proxy) [DirectiveUsage]
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, DeriveArguments TYPE InputTypeNamespace) => GQLType (Pair a b) where
  directives :: forall (f :: * -> *). f (Pair a b) -> DirectiveUsages
directives f (Pair a b)
_ = forall a. TypeDirectiveConstraint a => a -> DirectiveUsages
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, DeriveArguments TYPE InputTypeNamespace) => 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, DeriveArguments TYPE InputTypeNamespace) => 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. TypeDirectiveConstraint a => a -> DirectiveUsages
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 Decode a = EncodeKind (KIND a) a

encodeArguments :: forall m a. (MonadError GQLError m, Decode a) => a -> m (Arguments CONST)
encodeArguments :: forall (m :: * -> *) a.
(MonadError GQLError m, Decode 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. Decode 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!"
    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. Decode a => a -> GQLResult (Value CONST)
encode :: forall a. Decode 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, Decode 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. Decode 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

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, GQLType a) => ExplorerConstraint a

instance (EncodeKind (KIND a) a, GQLType 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 (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 a => a -> GQLResult (Value CONST)
__valueApply = forall a. Decode a => a -> GQLResult (Value CONST)
encode,
            __valueTypeName :: TypeName
__valueTypeName = forall a (kind :: TypeCategory) (kinded :: TypeCategory -> * -> *).
(GQLType a, CategoryValue kind) =>
kinded kind a -> TypeName
deriveTypename (forall {k} {k} (k :: k) (a :: k). KindedProxy k a
KindedProxy :: KindedProxy IN a),
            __valueGetType :: forall (f :: * -> *) a. ExplorerConstraint 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 (GQLResult (Value CONST))
      )

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

class DeriveArguments (k :: DerivingKind) a where
  deriveArgumentsDefinition :: f k a -> SchemaT OUT (ArgumentsDefinition CONST)

-- DIRECTIVES

data DirectiveUsages = DirectiveUsages
  { DirectiveUsages -> [DirectiveUsage]
typeDirectives :: [DirectiveUsage],
    DirectiveUsages -> HashMap FieldName [DirectiveUsage]
fieldDirectives :: M.HashMap FieldName [DirectiveUsage],
    DirectiveUsages -> HashMap TypeName [DirectiveUsage]
enumValueDirectives :: M.HashMap TypeName [DirectiveUsage]
  }

instance Monoid DirectiveUsages where
  mempty :: DirectiveUsages
mempty = [DirectiveUsage]
-> HashMap FieldName [DirectiveUsage]
-> HashMap TypeName [DirectiveUsage]
-> DirectiveUsages
DirectiveUsages forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty

mergeDirs :: (Eq k, Hashable k, Semigroup v) => HashMap k v -> HashMap k v -> HashMap k v
mergeDirs :: forall k v.
(Eq k, Hashable k, Semigroup v) =>
HashMap k v -> HashMap k v -> HashMap k v
mergeDirs HashMap k v
a HashMap k v
b = forall {k} {v}.
(Hashable k, Semigroup v) =>
HashMap k v -> [(k, v)] -> HashMap k v
update HashMap k v
a (forall k v. HashMap k v -> [(k, v)]
M.toList HashMap k v
b)
  where
    update :: HashMap k v -> [(k, v)] -> HashMap k v
update HashMap k v
m [] = HashMap k v
m
    update HashMap k v
m ((k, v)
x : [(k, v)]
xs) = HashMap k v -> [(k, v)] -> HashMap k v
update (forall k v.
(Eq k, Hashable k, Semigroup v) =>
(k, v) -> HashMap k v -> HashMap k v
upsert (k, v)
x HashMap k v
m) [(k, v)]
xs

upsert :: (Eq k, Hashable k, Semigroup v) => (k, v) -> HashMap k v -> HashMap k v
upsert :: forall k v.
(Eq k, Hashable k, Semigroup v) =>
(k, v) -> HashMap k v -> HashMap k v
upsert (k
k, v
v) = forall k v.
(Eq k, Hashable k) =>
(Maybe v -> Maybe v) -> k -> HashMap k v -> HashMap k v
M.alter (forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. b -> (a -> b) -> Maybe a -> b
maybe v
v (v
v forall a. Semigroup a => a -> a -> a
<>)) k
k

instance Semigroup DirectiveUsages where
  DirectiveUsages [DirectiveUsage]
td1 HashMap FieldName [DirectiveUsage]
fd1 HashMap TypeName [DirectiveUsage]
ed1 <> :: DirectiveUsages -> DirectiveUsages -> DirectiveUsages
<> DirectiveUsages [DirectiveUsage]
td2 HashMap FieldName [DirectiveUsage]
fd2 HashMap TypeName [DirectiveUsage]
ed2 =
    [DirectiveUsage]
-> HashMap FieldName [DirectiveUsage]
-> HashMap TypeName [DirectiveUsage]
-> DirectiveUsages
DirectiveUsages ([DirectiveUsage]
td1 forall a. Semigroup a => a -> a -> a
<> [DirectiveUsage]
td2) (forall k v.
(Eq k, Hashable k, Semigroup v) =>
HashMap k v -> HashMap k v -> HashMap k v
mergeDirs HashMap FieldName [DirectiveUsage]
fd1 HashMap FieldName [DirectiveUsage]
fd2) (forall k v.
(Eq k, Hashable k, Semigroup v) =>
HashMap k v -> HashMap k v -> HashMap k v
mergeDirs HashMap TypeName [DirectiveUsage]
ed1 HashMap TypeName [DirectiveUsage]
ed2)

type TypeDirectiveConstraint a = (GQLDirective a, GQLType a, Decode a, DeriveArguments (KIND a) a, ToLocations (DIRECTIVE_LOCATIONS a))

typeDirective :: TypeDirectiveConstraint a => a -> DirectiveUsages
typeDirective :: forall a. TypeDirectiveConstraint a => a -> DirectiveUsages
typeDirective a
x = [DirectiveUsage]
-> HashMap FieldName [DirectiveUsage]
-> HashMap TypeName [DirectiveUsage]
-> DirectiveUsages
DirectiveUsages [forall a.
(GQLDirective a, GQLType a, Decode a, DeriveArguments (KIND a) a,
 ToLocations (DIRECTIVE_LOCATIONS a)) =>
a -> DirectiveUsage
DirectiveUsage a
x] forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty

fieldDirective :: TypeDirectiveConstraint a => FieldName -> a -> DirectiveUsages
fieldDirective :: forall a.
TypeDirectiveConstraint a =>
FieldName -> a -> DirectiveUsages
fieldDirective FieldName
name a
x = [DirectiveUsage]
-> HashMap FieldName [DirectiveUsage]
-> HashMap TypeName [DirectiveUsage]
-> DirectiveUsages
DirectiveUsages forall a. Monoid a => a
mempty (forall k v. Hashable k => k -> v -> HashMap k v
M.singleton FieldName
name [forall a.
(GQLDirective a, GQLType a, Decode a, DeriveArguments (KIND a) a,
 ToLocations (DIRECTIVE_LOCATIONS a)) =>
a -> DirectiveUsage
DirectiveUsage a
x]) forall a. Monoid a => a
mempty

fieldDirective' :: TypeDirectiveConstraint a => TH.Name -> a -> DirectiveUsages
fieldDirective' :: forall a. TypeDirectiveConstraint a => Name -> a -> DirectiveUsages
fieldDirective' Name
name = forall a.
TypeDirectiveConstraint a =>
FieldName -> a -> DirectiveUsages
fieldDirective (forall a (t :: NAME). NamePacking a => a -> Name t
packName Name
name)

enumDirective :: TypeDirectiveConstraint a => TypeName -> a -> DirectiveUsages
enumDirective :: forall a.
TypeDirectiveConstraint a =>
TypeName -> a -> DirectiveUsages
enumDirective TypeName
name a
x = [DirectiveUsage]
-> HashMap FieldName [DirectiveUsage]
-> HashMap TypeName [DirectiveUsage]
-> DirectiveUsages
DirectiveUsages forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty (forall k v. Hashable k => k -> v -> HashMap k v
M.singleton TypeName
name [forall a.
(GQLDirective a, GQLType a, Decode a, DeriveArguments (KIND a) a,
 ToLocations (DIRECTIVE_LOCATIONS a)) =>
a -> DirectiveUsage
DirectiveUsage a
x])

enumDirective' :: TypeDirectiveConstraint a => TH.Name -> a -> DirectiveUsages
enumDirective' :: forall a. TypeDirectiveConstraint a => Name -> a -> DirectiveUsages
enumDirective' Name
name = forall a.
TypeDirectiveConstraint a =>
TypeName -> a -> DirectiveUsages
enumDirective (forall a (t :: NAME). NamePacking a => a -> Name t
packName Name
name)

data DirectiveUsage where
  DirectiveUsage :: (GQLDirective a, GQLType a, Decode a, DeriveArguments (KIND a) a, ToLocations (DIRECTIVE_LOCATIONS a)) => a -> DirectiveUsage

applyTypeName :: DirectiveUsage -> Bool -> TypeName -> TypeName
applyTypeName :: DirectiveUsage -> Bool -> TypeName -> TypeName
applyTypeName (DirectiveUsage a
x) = forall a. GQLDirective a => a -> Bool -> TypeName -> TypeName
visitTypeName' a
x

typeNameWithDirectives :: Bool -> TypeName -> [DirectiveUsage] -> TypeName
typeNameWithDirectives :: Bool -> TypeName -> [DirectiveUsage] -> TypeName
typeNameWithDirectives Bool
x = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (DirectiveUsage -> Bool -> TypeName -> TypeName
`applyTypeName` Bool
x)

applyTypeFieldNames :: DirectiveUsage -> FieldName -> FieldName
applyTypeFieldNames :: DirectiveUsage -> FieldName -> FieldName
applyTypeFieldNames (DirectiveUsage a
x) = forall a. GQLDirective a => a -> FieldName -> FieldName
visitFieldNames' a
x

applyTypeEnumNames :: DirectiveUsage -> TypeName -> TypeName
applyTypeEnumNames :: DirectiveUsage -> TypeName -> TypeName
applyTypeEnumNames (DirectiveUsage a
x) = forall a. GQLDirective a => a -> TypeName -> TypeName
visitEnumNames' a
x

applyEnumDescription :: DirectiveUsage -> Maybe Description -> Maybe Description
applyEnumDescription :: DirectiveUsage -> Maybe Text -> Maybe Text
applyEnumDescription (DirectiveUsage a
x) = forall a. GQLDirective a => a -> Maybe Text -> Maybe Text
visitEnumDescription' a
x

applyEnumName :: DirectiveUsage -> TypeName -> TypeName
applyEnumName :: DirectiveUsage -> TypeName -> TypeName
applyEnumName (DirectiveUsage a
x) = forall a. GQLDirective a => a -> TypeName -> TypeName
visitEnumName' a
x

applyFieldName :: DirectiveUsage -> FieldName -> FieldName
applyFieldName :: DirectiveUsage -> FieldName -> FieldName
applyFieldName (DirectiveUsage a
x) = forall a. GQLDirective a => a -> FieldName -> FieldName
visitFieldName' a
x

applyFieldDescription :: DirectiveUsage -> Maybe Description -> Maybe Description
applyFieldDescription :: DirectiveUsage -> Maybe Text -> Maybe Text
applyFieldDescription (DirectiveUsage a
x) = forall a. GQLDirective a => a -> Maybe Text -> Maybe Text
visitFieldDescription' a
x

applyFieldDefaultValue :: DirectiveUsage -> Maybe (Value CONST) -> Maybe (Value CONST)
applyFieldDefaultValue :: DirectiveUsage -> Maybe (Value CONST) -> Maybe (Value CONST)
applyFieldDefaultValue (DirectiveUsage a
x) = forall a.
GQLDirective a =>
a -> Maybe (Value CONST) -> Maybe (Value CONST)
visitFieldDefaultValue' a
x

applyTypeDescription :: DirectiveUsage -> Maybe Description -> Maybe Description
applyTypeDescription :: DirectiveUsage -> Maybe Text -> Maybe Text
applyTypeDescription (DirectiveUsage a
x) = forall a. GQLDirective a => a -> Maybe Text -> Maybe Text
visitTypeDescription' a
x

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 =
      '[ 'OBJECT,
         'ENUM,
         'INPUT_OBJECT,
         'UNION,
         'SCALAR,
         '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