{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Data.Morpheus.Server.Types.GQLType
( GQLType
( KIND,
description,
getDescriptions,
typeOptions,
getDirectives,
defaultValues,
__type
),
GQLTypeOptions (..),
defaultTypeOptions,
TypeData (..),
__isEmptyType,
__typeData,
)
where
import Data.Morpheus.App.Internal.Resolving
( Resolver,
SubscriptionField,
)
import Data.Morpheus.Kind
( CUSTOM,
DerivingKind,
SCALAR,
TYPE,
WRAPPER,
)
import Data.Morpheus.NamedResolvers (NamedResolverT (..))
import Data.Morpheus.Server.Deriving.Utils.Kinded (CategoryValue (..))
import Data.Morpheus.Server.Types.SchemaT
( TypeFingerprint (..),
)
import Data.Morpheus.Server.Types.Types
( Arg,
Pair,
TypeGuard,
Undefined (..),
)
import Data.Morpheus.Types.ID (ID)
import Data.Morpheus.Types.Internal.AST
( CONST,
Description,
Directives,
TypeCategory (..),
TypeName,
TypeWrapper (..),
Value,
mkBaseType,
packName,
toNullable,
unpackName,
)
import Data.Sequence (Seq)
import Data.Text
( intercalate,
pack,
unpack,
)
import Data.Typeable
( TyCon,
TypeRep,
splitTyConApp,
tyConFingerprint,
tyConName,
typeRep,
typeRepTyCon,
)
import Data.Vector (Vector)
import Relude hiding (Seq, Undefined, intercalate)
data TypeData = TypeData
{ TypeData -> TypeName
gqlTypeName :: TypeName,
TypeData -> TypeWrapper
gqlWrappers :: TypeWrapper,
TypeData -> TypeFingerprint
gqlFingerprint :: TypeFingerprint
}
deriving (Int -> TypeData -> ShowS
[TypeData] -> ShowS
TypeData -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TypeData] -> ShowS
$cshowList :: [TypeData] -> ShowS
show :: TypeData -> String
$cshow :: TypeData -> String
showsPrec :: Int -> TypeData -> ShowS
$cshowsPrec :: Int -> TypeData -> ShowS
Show)
data GQLTypeOptions = GQLTypeOptions
{
GQLTypeOptions -> ShowS
fieldLabelModifier :: String -> String,
GQLTypeOptions -> ShowS
constructorTagModifier :: String -> String,
GQLTypeOptions -> Bool -> ShowS
typeNameModifier :: Bool -> String -> String
}
defaultTypeOptions :: GQLTypeOptions
defaultTypeOptions :: GQLTypeOptions
defaultTypeOptions =
GQLTypeOptions
{ fieldLabelModifier :: ShowS
fieldLabelModifier = forall a. a -> a
id,
constructorTagModifier :: ShowS
constructorTagModifier = forall a. a -> a
id,
typeNameModifier :: Bool -> ShowS
typeNameModifier = forall a b. a -> b -> a
const forall a. a -> a
id
}
__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))
getTypename :: Typeable a => f a -> TypeName
getTypename :: forall a (f :: * -> *). Typeable a => f a -> TypeName
getTypename = forall a (t :: NAME). NamePacking a => a -> Name t
packName forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text] -> Text
intercalate Text
"" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a (f :: * -> *). Typeable a => f a -> [Text]
getTypeConstructorNames
getTypeConstructorNames :: Typeable a => f a -> [Text]
getTypeConstructorNames :: forall a (f :: * -> *). Typeable a => f a -> [Text]
getTypeConstructorNames = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String -> Text
pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyCon -> String
tyConName forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyCon -> TyCon
replacePairCon) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a (f :: * -> *). Typeable a => f a -> [TyCon]
getTypeConstructors
getTypeConstructors :: Typeable a => f a -> [TyCon]
getTypeConstructors :: forall a (f :: * -> *). Typeable a => f a -> [TyCon]
getTypeConstructors = (TyCon, [TypeRep]) -> [TyCon]
ignoreResolver forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeRep -> (TyCon, [TypeRep])
splitTyConApp forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep
prefixInputs :: GQLTypeOptions -> GQLTypeOptions
prefixInputs :: GQLTypeOptions -> GQLTypeOptions
prefixInputs GQLTypeOptions
options = GQLTypeOptions
options {typeNameModifier :: Bool -> ShowS
typeNameModifier = \Bool
isInput String
name -> if Bool
isInput then String
"Input" forall a. Semigroup a => a -> a -> a
<> String
name else String
name}
deriveTypeData :: Typeable a => f a -> (Bool -> String -> String) -> TypeCategory -> TypeData
deriveTypeData :: forall a (f :: * -> *).
Typeable a =>
f a -> (Bool -> ShowS) -> TypeCategory -> TypeData
deriveTypeData f a
proxy Bool -> ShowS
typeNameModifier TypeCategory
cat =
TypeData
{ gqlTypeName :: TypeName
gqlTypeName = forall a (t :: NAME). NamePacking a => a -> Name t
packName forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
pack forall a b. (a -> b) -> a -> b
$ Bool -> ShowS
typeNameModifier (TypeCategory
cat forall a. Eq a => a -> a -> Bool
== TypeCategory
IN) String
originalTypeName,
gqlWrappers :: TypeWrapper
gqlWrappers = TypeWrapper
mkBaseType,
gqlFingerprint :: TypeFingerprint
gqlFingerprint = forall a (f :: * -> *).
Typeable a =>
TypeCategory -> f a -> TypeFingerprint
getFingerprint TypeCategory
cat f a
proxy
}
where
originalTypeName :: String
originalTypeName = Text -> String
unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a (t :: NAME). NamePacking a => Name t -> a
unpackName forall a b. (a -> b) -> a -> b
$ forall a (f :: * -> *). Typeable a => f a -> TypeName
getTypename f a
proxy
getFingerprint :: Typeable a => TypeCategory -> f a -> TypeFingerprint
getFingerprint :: forall a (f :: * -> *).
Typeable a =>
TypeCategory -> f a -> TypeFingerprint
getFingerprint TypeCategory
category = TypeCategory -> [Fingerprint] -> TypeFingerprint
TypeableFingerprint TypeCategory
category forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TyCon -> Fingerprint
tyConFingerprint forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a (f :: * -> *). Typeable a => f a -> [TyCon]
getTypeConstructors
mkTypeData :: TypeName -> a -> TypeData
mkTypeData :: forall a. TypeName -> a -> TypeData
mkTypeData TypeName
name a
_ =
TypeData
{ gqlTypeName :: TypeName
gqlTypeName = TypeName
name,
gqlFingerprint :: TypeFingerprint
gqlFingerprint = TypeName -> TypeFingerprint
InternalFingerprint TypeName
name,
gqlWrappers :: TypeWrapper
gqlWrappers = TypeWrapper
mkBaseType
}
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
gqlFingerprint :: TypeData -> TypeFingerprint
gqlWrappers :: TypeData -> TypeWrapper
gqlTypeName :: TypeData -> TypeName
..} = TypeData {gqlWrappers :: TypeWrapper
gqlWrappers = TypeWrapper -> TypeWrapper
f TypeWrapper
gqlWrappers, TypeName
TypeFingerprint
gqlFingerprint :: TypeFingerprint
gqlTypeName :: TypeName
gqlFingerprint :: TypeFingerprint
gqlTypeName :: TypeName
..}
replacePairCon :: TyCon -> TyCon
replacePairCon :: TyCon -> TyCon
replacePairCon TyCon
x | TyCon
hsPair forall a. Eq a => a -> a -> Bool
== TyCon
x = TyCon
gqlPair
where
hsPair :: TyCon
hsPair = TypeRep -> TyCon
typeRepTyCon forall a b. (a -> b) -> a -> b
$ forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k). Proxy t
Proxy @(Int, Int)
gqlPair :: TyCon
gqlPair = TypeRep -> TyCon
typeRepTyCon forall a b. (a -> b) -> a -> b
$ forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k). Proxy t
Proxy @(Pair Int Int)
replacePairCon TyCon
x = TyCon
x
ignoreResolver :: (TyCon, [TypeRep]) -> [TyCon]
ignoreResolver :: (TyCon, [TypeRep]) -> [TyCon]
ignoreResolver (TyCon
con, [TypeRep]
_) | TyCon
con forall a. Eq a => a -> a -> Bool
== TypeRep -> TyCon
typeRepTyCon (forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k). Proxy t
Proxy @Resolver) = []
ignoreResolver (TyCon
con, [TypeRep]
_) | TyCon
con forall a. Eq a => a -> a -> Bool
== TypeRep -> TyCon
typeRepTyCon (forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k). Proxy t
Proxy @NamedResolverT) = []
ignoreResolver (TyCon
con, [TypeRep]
args) =
TyCon
con forall a. a -> [a] -> [a]
: forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((TyCon, [TypeRep]) -> [TyCon]
ignoreResolver forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeRep -> (TyCon, [TypeRep])
splitTyConApp) [TypeRep]
args
class GQLType a where
type KIND a :: DerivingKind
type KIND a = TYPE
description :: f a -> Maybe Text
description f a
_ = forall a. Maybe a
Nothing
getDescriptions :: f a -> Map Text Description
getDescriptions f a
_ = forall a. Monoid a => a
mempty
typeOptions :: f a -> GQLTypeOptions -> GQLTypeOptions
typeOptions f a
_ = forall a. a -> a
id
getDirectives :: f a -> Map Text (Directives CONST)
getDirectives f a
_ = forall a. Monoid a => a
mempty
defaultValues :: f a -> Map Text (Value CONST)
defaultValues f a
_ = forall a. Monoid a => a
mempty
__isEmptyType :: f a -> Bool
__isEmptyType f a
_ = Bool
False
__type :: f a -> TypeCategory -> TypeData
default __type :: Typeable a => f a -> TypeCategory -> TypeData
__type f a
proxy = forall a (f :: * -> *).
Typeable a =>
f a -> (Bool -> ShowS) -> TypeCategory -> TypeData
deriveTypeData f a
proxy Bool -> ShowS
typeNameModifier
where
GQLTypeOptions {Bool -> ShowS
typeNameModifier :: Bool -> ShowS
typeNameModifier :: GQLTypeOptions -> Bool -> ShowS
typeNameModifier} = forall a (f :: * -> *).
GQLType a =>
f a -> GQLTypeOptions -> GQLTypeOptions
typeOptions f a
proxy GQLTypeOptions
defaultTypeOptions
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 ()
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
typeOptions :: forall (f :: * -> *).
f (Pair a b) -> GQLTypeOptions -> GQLTypeOptions
typeOptions f (Pair a b)
_ = GQLTypeOptions -> GQLTypeOptions
prefixInputs
instance Typeable m => GQLType (Undefined m) where
type KIND (Undefined m) = CUSTOM
__isEmptyType :: forall (f :: * -> *). f (Undefined m) -> Bool
__isEmptyType f (Undefined m)
_ = Bool
True
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)
typeOptions :: forall (f :: * -> *). f (a, b) -> GQLTypeOptions -> GQLTypeOptions
typeOptions f (a, b)
_ = GQLTypeOptions -> GQLTypeOptions
prefixInputs
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)