{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
module Data.Morpheus.Parsing.Document.TypeSystem
( parseSchema,
)
where
import Data.Morpheus.Parsing.Internal.Internal
( Parser,
processParser,
)
import Data.Morpheus.Parsing.Internal.Pattern
( enumValueDefinition,
fieldsDefinition,
inputFieldsDefinition,
optionalDirectives,
typeDeclaration,
)
import Data.Morpheus.Parsing.Internal.Terms
( collection,
keyword,
operator,
optDescription,
parseTypeName,
pipeLiteral,
sepByAnd,
spaceAndComments,
)
import Data.Morpheus.Types.Internal.AST
( ANY,
DataFingerprint (..),
Description,
IN,
Meta (..),
OUT,
ScalarDefinition (..),
TypeContent (..),
TypeDefinition (..),
TypeName,
toAny,
)
import Data.Morpheus.Types.Internal.Resolving
( Eventless,
)
import Data.Text (Text)
import Text.Megaparsec
( (<|>),
eof,
label,
manyTill,
sepBy1,
)
scalarTypeDefinition :: Maybe Description -> Parser (TypeDefinition ANY)
scalarTypeDefinition metaDescription = label "ScalarTypeDefinition" $ do
typeName <- typeDeclaration "scalar"
metaDirectives <- optionalDirectives
pure
TypeDefinition
{ typeName,
typeMeta = Just Meta {metaDescription, metaDirectives},
typeFingerprint = DataFingerprint typeName [],
typeContent = DataScalar $ ScalarDefinition pure
}
objectTypeDefinition :: Maybe Description -> Parser (TypeDefinition OUT)
objectTypeDefinition metaDescription = label "ObjectTypeDefinition" $ do
typeName <- typeDeclaration "type"
objectImplements <- optionalImplementsInterfaces
metaDirectives <- optionalDirectives
objectFields <- fieldsDefinition
pure
TypeDefinition
{ typeName,
typeMeta = Just Meta {metaDescription, metaDirectives},
typeFingerprint = DataFingerprint typeName [],
typeContent = DataObject {objectImplements, objectFields}
}
optionalImplementsInterfaces :: Parser [TypeName]
optionalImplementsInterfaces = implements <|> pure []
where
implements =
label "ImplementsInterfaces" $ keyword "implements" *> sepByAnd parseTypeName
interfaceTypeDefinition :: Maybe Description -> Parser (TypeDefinition OUT)
interfaceTypeDefinition metaDescription = label "InterfaceTypeDefinition" $ do
typeName <- typeDeclaration "interface"
metaDirectives <- optionalDirectives
fields <- fieldsDefinition
pure
TypeDefinition
{ typeName,
typeMeta = Just Meta {metaDescription, metaDirectives},
typeFingerprint = DataFingerprint typeName [],
typeContent = DataInterface fields
}
unionTypeDefinition :: Maybe Description -> Parser (TypeDefinition OUT)
unionTypeDefinition metaDescription = label "UnionTypeDefinition" $ do
typeName <- typeDeclaration "union"
metaDirectives <- optionalDirectives
memberTypes <- unionMemberTypes
pure
TypeDefinition
{ typeName,
typeMeta = Just Meta {metaDescription, metaDirectives},
typeFingerprint = DataFingerprint typeName [],
typeContent = DataUnion memberTypes
}
where
unionMemberTypes = operator '=' *> parseTypeName `sepBy1` pipeLiteral
enumTypeDefinition :: Maybe Description -> Parser (TypeDefinition ANY)
enumTypeDefinition metaDescription = label "EnumTypeDefinition" $ do
typeName <- typeDeclaration "enum"
metaDirectives <- optionalDirectives
enumValuesDefinitions <- collection enumValueDefinition
pure
TypeDefinition
{ typeName,
typeContent = DataEnum enumValuesDefinitions,
typeFingerprint = DataFingerprint typeName [],
typeMeta = Just Meta {metaDescription, metaDirectives}
}
inputObjectTypeDefinition :: Maybe Description -> Parser (TypeDefinition IN)
inputObjectTypeDefinition metaDescription =
label "InputObjectTypeDefinition" $ do
typeName <- typeDeclaration "input"
metaDirectives <- optionalDirectives
fields <- inputFieldsDefinition
pure
TypeDefinition
{ typeName,
typeContent = DataInputObject fields,
typeFingerprint = DataFingerprint typeName [],
typeMeta = Just Meta {metaDescription, metaDirectives}
}
parseDataType :: Parser (TypeDefinition ANY)
parseDataType = label "TypeDefinition" $ do
description <- optDescription
(toAny <$> inputObjectTypeDefinition description)
<|> (toAny <$> unionTypeDefinition description)
<|> enumTypeDefinition description
<|> scalarTypeDefinition description
<|> (toAny <$> objectTypeDefinition description)
<|> (toAny <$> interfaceTypeDefinition description)
parseSchema :: Text -> Eventless [TypeDefinition ANY]
parseSchema = processParser request
where
request = label "DocumentTypes" $ do
spaceAndComments
manyTill parseDataType eof