{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
module Data.Morpheus.Types.GQLType
( GQLType(..)
, TRUE
, FALSE
)
where
import Data.Map ( Map )
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 Data.Morpheus.Kind
import Data.Morpheus.Types.Types ( MapKind
, Pair
, Undefined(..)
)
import Data.Morpheus.Types.Internal.AST.Data
( DataFingerprint(..)
, QUERY
)
import Data.Morpheus.Types.Internal.Resolving
( Resolver(..) )
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
class IsObject (KIND a) => GQLType a where
type KIND a :: GQL_KIND
type KIND a = OUTPUT
type CUSTOM a :: Bool
type CUSTOM a = FALSE
description :: Proxy a -> Maybe Text
description _ = Nothing
isObjectKind :: Proxy a -> Bool
isObjectKind _ = isObject (Proxy @(KIND a))
__typeName :: Proxy a -> Text
default __typeName :: (Typeable a) =>
Proxy a -> Text
__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
instance GQLType Float where
type KIND Float = SCALAR
instance GQLType Text where
type KIND Text = SCALAR
__typeName = const "String"
instance GQLType Bool where
type KIND Bool = SCALAR
__typeName = const "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)