{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Data.Morpheus.Server.Types.GQLType
( GQLType (..),
GQLTypeOptions (..),
defaultTypeOptions,
TypeData (..),
)
where
import Data.Map (Map)
import Data.Morpheus.Kind
import Data.Morpheus.Server.Types.SchemaT (SchemaT)
import Data.Morpheus.Server.Types.Types
( MapKind,
Pair,
Undefined (..),
)
import Data.Morpheus.Types.ID (ID)
import Data.Morpheus.Types.Internal.AST
( ArgumentsDefinition,
CONST,
DataFingerprint (..),
Description,
Directives,
FieldName,
QUERY,
TypeName (..),
TypeWrapper (..),
Value,
internalFingerprint,
toNullable,
)
import Data.Morpheus.Types.Internal.Resolving
( Resolver,
SubscriptionField,
)
import Data.Proxy (Proxy (..))
import Data.Set (Set)
import Data.Text
( Text,
intercalate,
pack,
)
import Data.Typeable
( TyCon,
TypeRep,
Typeable,
splitTyConApp,
tyConFingerprint,
tyConName,
typeRep,
typeRepTyCon,
)
import Prelude
( ($),
(.),
Bool (..),
Eq (..),
Float,
Int,
Maybe (..),
String,
concatMap,
fmap,
id,
mempty,
show,
)
data TypeData = TypeData
{ gqlTypeName :: TypeName,
gqlWrappers :: [TypeWrapper],
gqlFingerprint :: DataFingerprint
}
data GQLTypeOptions = GQLTypeOptions
{ fieldLabelModifier :: String -> String,
constructorTagModifier :: String -> String
}
defaultTypeOptions :: GQLTypeOptions
defaultTypeOptions =
GQLTypeOptions
{ fieldLabelModifier = id,
constructorTagModifier = id
}
getTypename :: Typeable a => f a -> TypeName
getTypename = TypeName . intercalate "_" . getName
where
getName = fmap (fmap (pack . tyConName)) (fmap replacePairCon . ignoreResolver . splitTyConApp . typeRep)
getFingerprint :: Typeable a => f a -> DataFingerprint
getFingerprint = DataFingerprint "Typeable" . fmap show . conFingerprints
where
conFingerprints = fmap (fmap tyConFingerprint) (ignoreResolver . splitTyConApp . typeRep)
deriveTypeData :: Typeable a => f a -> TypeData
deriveTypeData proxy =
TypeData
{ gqlTypeName = getTypename proxy,
gqlWrappers = [],
gqlFingerprint = getFingerprint proxy
}
mkTypeData :: TypeName -> TypeData
mkTypeData name =
TypeData
{ gqlTypeName = name,
gqlFingerprint = internalFingerprint name [],
gqlWrappers = []
}
list :: [TypeWrapper] -> [TypeWrapper]
list = (TypeList :)
wrapper :: ([TypeWrapper] -> [TypeWrapper]) -> TypeData -> TypeData
wrapper f TypeData {..} = TypeData {gqlWrappers = f gqlWrappers, ..}
resolverCon :: TyCon
resolverCon = typeRepTyCon $ typeRep $ Proxy @(Resolver QUERY () Maybe)
replacePairCon :: TyCon -> TyCon
replacePairCon x | hsPair == x = gqlPair
where
hsPair = typeRepTyCon $ typeRep $ Proxy @(Int, Int)
gqlPair = typeRepTyCon $ typeRep $ Proxy @(Pair Int Int)
replacePairCon x = x
ignoreResolver :: (TyCon, [TypeRep]) -> [TyCon]
ignoreResolver (con, _) | con == resolverCon = []
ignoreResolver (con, args) =
con : concatMap (ignoreResolver . splitTyConApp) args
class ToValue (KIND a) => GQLType a where
type KIND a :: GQL_KIND
type KIND a = OUTPUT
implements :: f a -> [SchemaT TypeName]
implements _ = []
isObjectKind :: f a -> Bool
isObjectKind _ = isObject $ toValue (Proxy @(KIND a))
description :: f a -> Maybe Text
description _ = Nothing
getDescriptions :: f a -> Map Text Description
getDescriptions _ = mempty
typeOptions :: f a -> GQLTypeOptions
typeOptions _ = defaultTypeOptions
getDirectives :: f a -> Map Text (Directives CONST)
getDirectives _ = mempty
getFieldContents ::
f a ->
Map
FieldName
( Maybe (Value CONST),
Maybe (ArgumentsDefinition CONST)
)
getFieldContents _ = mempty
isEmptyType :: f a -> Bool
isEmptyType _ = False
__type :: f a -> TypeData
default __type :: Typeable a => f a -> TypeData
__type _ = deriveTypeData (Proxy @a)
instance GQLType Int where
type KIND Int = SCALAR
__type _ = mkTypeData "Int"
instance GQLType Float where
type KIND Float = SCALAR
__type _ = mkTypeData "Float"
instance GQLType Text where
type KIND Text = SCALAR
__type _ = mkTypeData "String"
instance GQLType Bool where
type KIND Bool = SCALAR
__type _ = mkTypeData "Boolean"
instance GQLType ID where
type KIND ID = SCALAR
__type _ = mkTypeData "ID"
instance GQLType ()
instance Typeable m => GQLType (Undefined m) where
type KIND (Undefined m) = WRAPPER
isEmptyType _ = True
instance GQLType a => GQLType (Maybe a) where
type KIND (Maybe a) = WRAPPER
__type _ = wrapper toNullable $ __type $ Proxy @a
instance GQLType a => GQLType [a] where
type KIND [a] = WRAPPER
__type _ = wrapper list $ __type $ Proxy @a
instance (Typeable a, Typeable b, GQLType a, GQLType b) => GQLType (a, b) where
type KIND (a, b) = WRAPPER
__type _ = __type $ Proxy @(Pair a b)
instance GQLType a => GQLType (Set a) where
type KIND (Set a) = WRAPPER
__type _ = __type $ Proxy @[a]
instance (Typeable k, Typeable v) => GQLType (Map k v) where
type KIND (Map k v) = WRAPPER
instance GQLType a => GQLType (Resolver o e m a) where
type KIND (Resolver o e m a) = WRAPPER
__type _ = __type $ Proxy @a
instance GQLType a => GQLType (SubscriptionField a) where
type KIND (SubscriptionField a) = WRAPPER
__type _ = __type $ Proxy @a
instance GQLType b => GQLType (a -> b) where
type KIND (a -> b) = WRAPPER
__type _ = __type $ Proxy @b
instance (Typeable a, Typeable b, GQLType a, GQLType b) => GQLType (Pair a b)
instance (Typeable a, Typeable b, GQLType a, GQLType b) => GQLType (MapKind a b m) where
__type _ = __type $ Proxy @(Map a b)