{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Data.Morpheus.Resolve.Introspect
( introspectOutputType
) where
import Data.Map (Map)
import Data.Morpheus.Error.Schema (nameCollisionError)
import Data.Morpheus.Kind (ENUM, INPUT_OBJECT, KIND, OBJECT, SCALAR, UNION, WRAPPER)
import Data.Morpheus.Resolve.Generics.EnumRep (EnumRep (..))
import Data.Morpheus.Resolve.Generics.TypeRep (ObjectRep (..), RecSel, SelOf, TypeUpdater, UnionRep (..),
resolveTypes)
import Data.Morpheus.Types.Custom (MapKind, Pair)
import Data.Morpheus.Types.GQLScalar (GQLScalar (..))
import Data.Morpheus.Types.GQLType (GQLType (..))
import Data.Morpheus.Types.Internal.Data (DataArguments, DataField (..), DataFullType (..),
DataInputField, DataLeaf (..), DataType (..),
DataTypeKind (..), DataTypeWrapper (..), DataValidator,
defineType, isTypeDefined)
import Data.Morpheus.Types.Resolver (Resolver)
import Data.Proxy (Proxy (..))
import Data.Set (Set)
import Data.Text (Text, pack)
import GHC.Generics
type GQL_TYPE a = (Generic a, GQLType a)
type EnumConstraint a = (GQL_TYPE a, EnumRep (Rep a))
type InputObjectConstraint a = (GQL_TYPE a, ObjectRep (Rep a) ())
type ObjectConstraint a = (GQL_TYPE a, ObjectRep (Rep a) DataArguments)
type UnionConstraint a = (GQL_TYPE a, UnionRep (Rep a))
scalarTypeOf :: GQLType a => DataValidator -> Proxy a -> DataFullType
scalarTypeOf validator = Leaf . LeafScalar . buildType validator
enumTypeOf :: GQLType a => [Text] -> Proxy a -> DataFullType
enumTypeOf tags' = Leaf . LeafEnum . buildType tags'
type InputType = ()
type OutputType = DataArguments
type InputOf t = Context t (KIND t) InputType
type OutputOf t = Context t (KIND t) OutputType
introspectOutputType ::
forall a. Introspect a (KIND a) OutputType
=> Proxy a
-> TypeUpdater
introspectOutputType _ = introspect (Context :: OutputOf a)
data Context a kind args =
Context
buildField :: GQLType a => DataTypeKind -> Proxy a -> t -> Text -> DataField t
buildField fieldKind proxy' fieldArgs fieldName =
DataField
{ fieldName
, fieldKind
, fieldArgs
, fieldTypeWrappers = [NonNullType]
, fieldType = __typeName proxy'
, fieldHidden = False
}
buildType :: GQLType a => t -> Proxy a -> DataType t
buildType typeData proxy =
DataType
{ typeName = __typeName proxy
, typeFingerprint = __typeFingerprint proxy
, typeDescription = description proxy
, typeData
}
updateLib :: GQLType a => (Proxy a -> DataFullType) -> [TypeUpdater] -> Proxy a -> TypeUpdater
updateLib typeBuilder stack proxy lib' =
case isTypeDefined (__typeName proxy) lib' of
Nothing -> resolveTypes (defineType (__typeName proxy, typeBuilder proxy) lib') stack
Just fingerprint'
| fingerprint' == __typeFingerprint proxy -> return lib'
Just _ -> Left $ nameCollisionError (__typeName proxy)
class Introspect a kind args where
__field :: Context a kind args -> Text -> DataField args
introspect :: Context a kind args -> TypeUpdater
type OutputConstraint a = Introspect a (KIND a) DataArguments
instance (GQLScalar a, GQLType a) => Introspect a SCALAR InputType where
__field _ = buildField KindScalar (Proxy @a) ()
introspect _ = updateLib (scalarTypeOf (scalarValidator $ Proxy @a)) [] (Proxy @a)
instance (GQLScalar a, GQLType a) => Introspect a SCALAR OutputType where
__field _ = buildField KindScalar (Proxy @a) []
introspect _ = updateLib (scalarTypeOf (scalarValidator $ Proxy @a)) [] (Proxy @a)
instance EnumConstraint a => Introspect a ENUM InputType where
__field _ = buildField KindEnum (Proxy @a) ()
introspect _ = introspectEnum (Context :: InputOf a)
instance EnumConstraint a => Introspect a ENUM OutputType where
__field _ = buildField KindEnum (Proxy @a) []
introspect _ = introspectEnum (Context :: OutputOf a)
introspectEnum ::
forall a f. (GQLType a, EnumRep (Rep a))
=> Context a (KIND a) f
-> TypeUpdater
introspectEnum _ = updateLib (enumTypeOf $ getTags (Proxy @(Rep a))) [] (Proxy @a)
instance InputObjectConstraint a => Introspect a INPUT_OBJECT InputType where
__field _ = buildField KindInputObject (Proxy @a) ()
introspect _ = updateLib (InputObject . buildType fields') stack' (Proxy @a)
where
(fields', stack') = unzip $ objectFieldTypes (Proxy @(Rep a))
instance ObjectConstraint a => Introspect a OBJECT OutputType where
__field _ = buildField KindObject (Proxy @a) []
introspect _ = updateLib (OutputObject . buildType (__typename : fields')) stack' (Proxy @a)
where
__typename =
( "__typename"
, DataField
{ fieldName = "__typename"
, fieldKind = KindScalar
, fieldArgs = []
, fieldTypeWrappers = []
, fieldType = "String"
, fieldHidden = True
})
(fields', stack') = unzip $ objectFieldTypes (Proxy @(Rep a))
instance (Selector s, Introspect a (KIND a) f) => ObjectRep (RecSel s a) f where
objectFieldTypes _ =
[((name, __field (Context :: Context a (KIND a) f) name), introspect (Context :: Context a (KIND a) f))]
where
name = pack $ selName (undefined :: SelOf s)
instance (OutputConstraint a, ObjectConstraint a) => UnionRep (RecSel s a) where
possibleTypes _ = [(buildField KindObject (Proxy @a) () "", introspect (Context :: OutputOf a))]
instance UnionConstraint a => Introspect a UNION OutputType where
__field _ = buildField KindUnion (Proxy @a) []
introspect _ = updateLib (Union . buildType fields) stack (Proxy @a)
where
(fields, stack) = unzip $ possibleTypes (Proxy @(Rep a))
instance Introspect a (KIND a) f => Introspect (Maybe a) WRAPPER f where
__field _ name = maybeField $ __field (Context :: Context a (KIND a) f) name
where
maybeField :: DataField f -> DataField f
maybeField field@DataField {fieldTypeWrappers = NonNullType:xs} = field {fieldTypeWrappers = xs}
maybeField field = field
introspect _ = introspect (Context :: Context a (KIND a) f)
instance Introspect a (KIND a) f => Introspect [a] WRAPPER f where
__field _ name = listField (__field (Context :: Context a (KIND a) f) name)
where
listField :: DataField f -> DataField f
listField x = x {fieldTypeWrappers = [NonNullType, ListType] ++ fieldTypeWrappers x}
introspect _ = introspect (Context :: Context a (KIND a) f)
instance Introspect (Pair k v) OBJECT f => Introspect (k, v) WRAPPER f where
__field _ = __field (Context :: Context (Pair k v) OBJECT f)
introspect _ = introspect (Context :: Context (Pair k v) OBJECT f)
instance Introspect [a] WRAPPER f => Introspect (Set a) WRAPPER f where
__field _ = __field (Context :: Context [a] WRAPPER f)
introspect _ = introspect (Context :: Context [a] WRAPPER f)
type MockRes = (Resolver Maybe)
instance Introspect (MapKind k v MockRes) OBJECT f => Introspect (Map k v) WRAPPER f where
__field _ = __field (Context :: Context (MapKind k v MockRes) OBJECT f)
introspect _ = introspect (Context :: Context (MapKind k v MockRes) OBJECT f)
instance (ObjectRep (Rep a) (), OutputConstraint b) => Introspect (a -> Resolver m b) WRAPPER OutputType where
__field _ name = (__field (Context :: OutputOf b) name) {fieldArgs = map fst $ objectFieldTypes (Proxy @(Rep a))}
introspect _ typeLib = resolveTypes typeLib $ map snd args ++ [introspect (Context :: OutputOf b)]
where
args :: [((Text, DataInputField), TypeUpdater)]
args = objectFieldTypes (Proxy @(Rep a))
instance (ObjectRep (Rep a) (), OutputConstraint b) => Introspect (a -> Either String b) WRAPPER OutputType where
__field _ name = (__field (Context :: OutputOf b) name) {fieldArgs = map fst $ objectFieldTypes (Proxy @(Rep a))}
introspect _ typeLib = resolveTypes typeLib $ map snd args ++ [introspect (Context :: OutputOf b)]
where
args :: [((Text, DataInputField), TypeUpdater)]
args = objectFieldTypes (Proxy @(Rep a))