{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeOperators #-}
module Data.Morpheus.Rendering.RenderIntrospection
( render,
createObjectType,
)
where
import Data.Maybe (isJust)
import Data.Morpheus.Internal.Utils
( elems,
failure,
selectBy,
)
import Data.Morpheus.Schema.TypeKind (TypeKind (..))
import Data.Morpheus.Types.Internal.AST
( ArgumentsDefinition (..),
DataEnumValue (..),
DataInputUnion,
DataInputUnion,
DataTypeKind (..),
DataTypeWrapper (..),
DataUnion,
Description,
DirectiveDefinition (..),
DirectiveLocation,
FieldDefinition (..),
FieldName (..),
FieldsDefinition,
IN,
Message,
Meta (..),
OUT,
QUERY,
Schema,
TypeContent (..),
TypeDefinition (..),
TypeName (..),
TypeRef (..),
createInputUnionFields,
fieldVisibility,
kindOf,
lookupDeprecated,
lookupDeprecatedReason,
msg,
toGQLWrapper,
)
import Data.Morpheus.Types.Internal.Resolving
( ResModel,
Resolver,
mkBoolean,
mkList,
mkNull,
mkObject,
mkString,
)
import Data.Semigroup ((<>))
import Data.Text (pack)
constRes :: Applicative m => a -> b -> m a
constRes = const . pure
type Result e m a = Schema -> Resolver QUERY e m a
class RenderSchema a where
render :: (Monad m) => a -> Schema -> Resolver QUERY e m (ResModel QUERY e m)
instance RenderSchema DirectiveDefinition where
render
DirectiveDefinition
{ directiveDefinitionName,
directiveDefinitionDescription,
directiveDefinitionLocations,
directiveDefinitionArgs
}
schema =
pure $
mkObject
"__Directive"
[ renderFieldName directiveDefinitionName,
renderDescription directiveDefinitionDescription,
("locations", render directiveDefinitionLocations schema),
("args", mkList <$> renderArguments directiveDefinitionArgs schema)
]
instance RenderSchema a => RenderSchema [a] where
render ls schema = mkList <$> traverse (`render` schema) ls
instance RenderSchema DirectiveLocation where
render locations _ = pure $ mkString (pack $ show locations)
instance RenderSchema (TypeDefinition a) where
render TypeDefinition {typeName, typeMeta, typeContent} = __render typeContent
where
__render ::
(Monad m) => TypeContent bool a -> Schema -> Resolver QUERY e m (ResModel QUERY e m)
__render DataScalar {} =
constRes $ createLeafType SCALAR typeName typeMeta Nothing
__render (DataEnum enums) =
constRes $
createLeafType ENUM typeName typeMeta (Just $ map createEnumValue enums)
__render (DataInputObject fields) = \lib ->
createInputObject typeName typeMeta
<$> traverse (`renderinputValue` lib) (elems fields)
__render DataObject {objectImplements, objectFields} =
pure . createObjectType typeName typeMeta objectImplements objectFields
__render (DataUnion union) = \schema ->
pure $ typeFromUnion schema (typeName, typeMeta, union)
__render (DataInputUnion members) =
renderInputUnion (typeName, typeMeta, members)
__render (DataInterface fields) =
renderInterface typeName Nothing fields
renderFields :: Monad m => Schema -> FieldsDefinition cat -> Resolver QUERY e m [ResModel QUERY e m]
renderFields schema = traverse (`render` schema) . filter fieldVisibility . elems
renderInterface ::
Monad m => TypeName -> Maybe Meta -> FieldsDefinition OUT -> Schema -> Resolver QUERY e m (ResModel QUERY e m)
renderInterface name meta fields schema =
pure $
mkObject
"__Type"
[ renderKind INTERFACE,
renderName name,
description meta,
("fields", mkList <$> renderFields schema fields),
("possibleTypes", mkList <$> interfacePossibleTypes schema name)
]
interfacePossibleTypes ::
(Monad m) =>
Schema ->
TypeName ->
Resolver QUERY e m [ResModel QUERY e m]
interfacePossibleTypes schema interfaceName = sequence $ concatMap implements (elems schema)
where
implements typeDef@TypeDefinition {typeContent = DataObject {objectImplements}, ..}
| interfaceName `elem` objectImplements = [render typeDef schema]
implements _ = []
createEnumValue :: Monad m => DataEnumValue -> ResModel QUERY e m
createEnumValue DataEnumValue {enumName, enumMeta} =
mkObject "__Field" $
[ renderName enumName,
description enumMeta
]
<> renderDeprecated enumMeta
renderDeprecated ::
(Monad m) =>
Maybe Meta ->
[(FieldName, Resolver QUERY e m (ResModel QUERY e m))]
renderDeprecated meta =
[ ("isDeprecated", pure $ mkBoolean (isJust $ meta >>= lookupDeprecated)),
("deprecationReason", opt (pure . mkString) (meta >>= lookupDeprecated >>= lookupDeprecatedReason))
]
description :: Monad m => Maybe Meta -> (FieldName, Resolver QUERY e m (ResModel QUERY e m))
description enumMeta = renderDescription (enumMeta >>= metaDescription)
renderDescription :: Monad m => Maybe Description -> (FieldName, Resolver QUERY e m (ResModel QUERY e m))
renderDescription desc = ("description", opt (pure . mkString) desc)
renderArguments :: (Monad m) => ArgumentsDefinition -> Schema -> Resolver QUERY e m [ResModel QUERY e m]
renderArguments ArgumentsDefinition {arguments} lib = traverse (`renderinputValue` lib) $ elems arguments
renderArguments NoArguments _ = pure []
instance RenderSchema (FieldDefinition cat) where
render field@FieldDefinition {fieldName, fieldType = TypeRef {typeConName}, fieldArgs, fieldMeta} lib =
do
kind <- renderTypeKind <$> lookupKind typeConName lib
pure
$ mkObject "__Field"
$ [ renderFieldName fieldName,
description fieldMeta,
("args", mkList <$> renderArguments fieldArgs lib),
("type", pure (withTypeWrapper field $ createType kind typeConName Nothing $ Just []))
]
<> renderDeprecated fieldMeta
renderTypeKind :: DataTypeKind -> TypeKind
renderTypeKind KindScalar = SCALAR
renderTypeKind (KindObject _) = OBJECT
renderTypeKind KindUnion = UNION
renderTypeKind KindInputUnion = INPUT_OBJECT
renderTypeKind KindEnum = ENUM
renderTypeKind KindInputObject = INPUT_OBJECT
renderTypeKind KindList = LIST
renderTypeKind KindNonNull = NON_NULL
renderTypeKind KindInterface = INTERFACE
lookupKind :: (Monad m) => TypeName -> Result e m DataTypeKind
lookupKind name schema = kindOf <$> selectBy ("Kind Not Found: " <> msg name) name schema
renderinputValue ::
(Monad m) =>
FieldDefinition IN ->
Result e m (ResModel QUERY e m)
renderinputValue input = fmap (createInputValueWith (fieldName input) (fieldMeta input)) . createInputObjectType input
createInputObjectType ::
(Monad m) => FieldDefinition IN -> Result e m (ResModel QUERY e m)
createInputObjectType field@FieldDefinition {fieldType = TypeRef {typeConName}} lib =
do
kind <- renderTypeKind <$> lookupKind typeConName lib
pure $ withTypeWrapper field $ createType kind typeConName Nothing $ Just []
renderInputUnion ::
(Monad m) =>
(TypeName, Maybe Meta, DataInputUnion) ->
Result e m (ResModel QUERY e m)
renderInputUnion (key, meta, fields) lib =
createInputObject key meta
<$> traverse
createField
(createInputUnionFields key $ map fst $ filter snd fields)
where
createField field =
createInputValueWith (fieldName field) Nothing <$> createInputObjectType field lib
createLeafType ::
Monad m =>
TypeKind ->
TypeName ->
Maybe Meta ->
Maybe [ResModel QUERY e m] ->
ResModel QUERY e m
createLeafType kind name meta enums =
mkObject
"__Type"
[ renderKind kind,
renderName name,
description meta,
("enumValues", optList enums)
]
typeFromUnion :: Monad m => Schema -> (TypeName, Maybe Meta, DataUnion) -> ResModel QUERY e m
typeFromUnion schema (name, typeMeta, typeContent) =
mkObject
"__Type"
[ renderKind UNION,
renderName name,
description typeMeta,
("possibleTypes", mkList <$> traverse (unionPossibleType schema) typeContent)
]
unionPossibleType :: Monad m => Schema -> TypeName -> Resolver QUERY e m (ResModel QUERY e m)
unionPossibleType schema name =
selectBy (" INTERNAL: INTROSPECTION Type not Found: \"" <> msg name <> "\"") name schema
>>= (`render` schema)
createObjectType ::
Monad m => TypeName -> Maybe Meta -> [TypeName] -> FieldsDefinition OUT -> Schema -> ResModel QUERY e m
createObjectType name meta interfaces fields schema =
mkObject
"__Type"
[ renderKind OBJECT,
renderName name,
description meta,
("fields", mkList <$> renderFields schema fields),
("interfaces", mkList <$> traverse (implementedInterface schema) interfaces)
]
implementedInterface ::
(Monad m) =>
Schema ->
TypeName ->
Resolver QUERY e m (ResModel QUERY e m)
implementedInterface schema name =
selectBy ("INTERNAL: cant found Interface " <> msg name) name schema
>>= __render
where
__render typeDef@TypeDefinition {typeContent = DataInterface {}} = render typeDef schema
__render _ = failure ("Type " <> msg name <> " must be an Interface" :: Message)
optList :: Monad m => Maybe [ResModel QUERY e m] -> Resolver QUERY e m (ResModel QUERY e m)
optList = pure . maybe mkNull mkList
createInputObject ::
Monad m => TypeName -> Maybe Meta -> [ResModel QUERY e m] -> ResModel QUERY e m
createInputObject name meta fields =
mkObject
"__Type"
[ renderKind INPUT_OBJECT,
renderName name,
description meta,
("inputFields", pure $ mkList fields)
]
createType ::
Monad m =>
TypeKind ->
TypeName ->
Maybe Meta ->
Maybe [ResModel QUERY e m] ->
ResModel QUERY e m
createType kind name desc fields =
mkObject
"__Type"
[ renderKind kind,
renderName name,
description desc,
("fields", pure $ maybe mkNull mkList fields),
("enumValues", pure $ mkList [])
]
opt :: Monad m => (a -> Resolver QUERY e m (ResModel QUERY e m)) -> Maybe a -> Resolver QUERY e m (ResModel QUERY e m)
opt f (Just x) = f x
opt _ Nothing = pure mkNull
renderName :: Monad m => TypeName -> (FieldName, Resolver QUERY e m (ResModel QUERY e m))
renderName = ("name",) . pure . mkString . readTypeName
renderFieldName :: Monad m => FieldName -> (FieldName, Resolver QUERY e m (ResModel QUERY e m))
renderFieldName (FieldName name) = ("name", pure $ mkString name)
renderKind :: Monad m => TypeKind -> (FieldName, Resolver QUERY e m (ResModel QUERY e m))
renderKind = ("kind",) . pure . mkString . pack . show
withTypeWrapper :: Monad m => FieldDefinition cat -> ResModel QUERY e m -> ResModel QUERY e m
withTypeWrapper FieldDefinition {fieldType = TypeRef {typeWrappers}} typ =
foldr wrapAs typ (toGQLWrapper typeWrappers)
wrapAs :: Monad m => DataTypeWrapper -> ResModel QUERY e m -> ResModel QUERY e m
wrapAs wrapper contentType =
mkObject
"__Type"
[ renderKind (kind wrapper),
("ofType", pure contentType)
]
where
kind ListType = LIST
kind NonNullType = NON_NULL
createInputValueWith ::
Monad m => FieldName -> Maybe Meta -> ResModel QUERY e m -> ResModel QUERY e m
createInputValueWith name meta ivType =
mkObject
"__InputValue"
[ renderFieldName name,
description meta,
("type", pure ivType)
]