{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
module Data.Morpheus.Server.Types.GQLType
( GQLType (..),
TRUE,
FALSE,
)
where
import Data.Map (Map)
import Data.Morpheus.Kind
import Data.Morpheus.Server.Types.Types
( MapKind,
Pair,
Undefined (..),
)
import Data.Morpheus.Types.Internal.AST
( DataFingerprint (..),
QUERY,
TypeName (..),
TypeUpdater,
internalFingerprint,
)
import Data.Morpheus.Types.Internal.Resolving
( Resolver,
)
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,
)
type TRUE = 'True
type FALSE = 'False
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 IsObject (a :: GQL_KIND) where
isObject :: Proxy a -> Bool
instance IsObject SCALAR where
isObject _ = False
instance IsObject ENUM where
isObject _ = False
instance IsObject WRAPPER where
isObject _ = False
instance IsObject INPUT where
isObject _ = True
instance IsObject OUTPUT where
isObject _ = True
instance IsObject INTERFACE where
isObject _ = True
class IsObject (KIND a) => GQLType a where
type KIND a :: GQL_KIND
type KIND a = OUTPUT
type CUSTOM a :: Bool
type CUSTOM a = FALSE
implements :: Proxy a -> [(TypeName, TypeUpdater)]
implements _ = []
description :: Proxy a -> Maybe Text
description _ = Nothing
isObjectKind :: Proxy a -> Bool
isObjectKind _ = isObject (Proxy @(KIND a))
__typeName :: Proxy a -> TypeName
default __typeName ::
(Typeable a) =>
Proxy a ->
TypeName
__typeName _ = TypeName $ intercalate "_" (getName $ Proxy @a)
where
getName = fmap (map (pack . tyConName)) (map replacePairCon . ignoreResolver . splitTyConApp . typeRep)
__typeFingerprint :: Proxy a -> DataFingerprint
default __typeFingerprint ::
(Typeable a) =>
Proxy a ->
DataFingerprint
__typeFingerprint _ = DataFingerprint "Typeable" $ map show $ conFingerprints (Proxy @a)
where
conFingerprints = fmap (map tyConFingerprint) (ignoreResolver . splitTyConApp . typeRep)
instance GQLType () where
type KIND () = WRAPPER
type CUSTOM () = 'False
instance Typeable m => GQLType (Undefined m) where
type KIND (Undefined m) = WRAPPER
type CUSTOM (Undefined m) = 'False
instance GQLType Int where
type KIND Int = SCALAR
__typeFingerprint _ = internalFingerprint "Int" []
instance GQLType Float where
type KIND Float = SCALAR
__typeFingerprint _ = internalFingerprint "Float" []
instance GQLType Text where
type KIND Text = SCALAR
__typeName _ = "String"
__typeFingerprint _ = internalFingerprint "String" []
instance GQLType Bool where
type KIND Bool = SCALAR
__typeName _ = "Boolean"
__typeFingerprint _ = internalFingerprint "Boolean" []
instance GQLType a => GQLType (Maybe a) where
type KIND (Maybe a) = WRAPPER
__typeName _ = __typeName (Proxy @a)
__typeFingerprint _ = __typeFingerprint (Proxy @a)
instance GQLType a => GQLType [a] where
type KIND [a] = WRAPPER
__typeName _ = __typeName (Proxy @a)
__typeFingerprint _ = __typeFingerprint (Proxy @a)
instance (Typeable a, Typeable b, GQLType a, GQLType b) => GQLType (a, b) where
type KIND (a, b) = WRAPPER
__typeName _ = __typeName $ Proxy @(Pair a b)
instance GQLType a => GQLType (Set a) where
type KIND (Set a) = WRAPPER
__typeName _ = __typeName (Proxy @a)
__typeFingerprint _ = __typeFingerprint (Proxy @a)
instance (Typeable a, Typeable b, GQLType a, GQLType b) => GQLType (Pair a b) where
type KIND (Pair a b) = OUTPUT
instance (Typeable a, Typeable b, GQLType a, GQLType b) => GQLType (MapKind a b m) where
type KIND (MapKind a b m) = OUTPUT
__typeName _ = __typeName (Proxy @(Map a b))
__typeFingerprint _ = __typeFingerprint (Proxy @(Map a b))
instance (Typeable k, Typeable v) => GQLType (Map k v) where
type KIND (Map k v) = WRAPPER
instance GQLType a => GQLType (Either s a) where
type KIND (Either s a) = WRAPPER
__typeName _ = __typeName (Proxy @a)
__typeFingerprint _ = __typeFingerprint (Proxy @a)
instance GQLType a => GQLType (Resolver o e m a) where
type KIND (Resolver o e m a) = WRAPPER
__typeName _ = __typeName (Proxy @a)
__typeFingerprint _ = __typeFingerprint (Proxy @a)
instance GQLType b => GQLType (a -> b) where
type KIND (a -> b) = WRAPPER
__typeName _ = __typeName (Proxy @b)
__typeFingerprint _ = __typeFingerprint (Proxy @b)