{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Data.Morpheus.Parsing.Document.TypeSystem
( parseSchema,
parseTypeDefinitions,
)
where
import Control.Applicative ((*>), pure)
import Control.Monad ((>=>))
import Data.Foldable (foldr)
import Data.Functor ((<$>), fmap)
import Data.Maybe (Maybe (..))
import Data.Morpheus.Error.NameCollision (NameCollision (..))
import Data.Morpheus.Parsing.Internal.Internal
( Parser,
processParser,
)
import Data.Morpheus.Parsing.Internal.Pattern
( argumentsDefinition,
enumValueDefinition,
fieldsDefinition,
inputFieldsDefinition,
optionalDirectives,
parseDirectiveLocation,
parseOperationType,
typeDeclaration,
)
import Data.Morpheus.Parsing.Internal.Terms
( collection,
ignoredTokens,
keyword,
optDescription,
optionalCollection,
parseName,
parseTypeName,
pipe,
sepByAnd,
setOf,
symbol,
)
import Data.Morpheus.Parsing.Internal.Value
( Parse (..),
)
import Data.Morpheus.Types.Internal.AST
( ANY,
CONST,
DataFingerprint (..),
Description,
DirectiveDefinition (..),
IN,
OUT,
RawTypeDefinition (..),
RootOperationTypeDefinition (..),
ScalarDefinition (..),
Schema,
SchemaDefinition (..),
TypeContent (..),
TypeDefinition (..),
TypeName,
Value,
buildSchema,
mkUnionMember,
toAny,
)
import Data.Morpheus.Types.Internal.Resolving
( Eventless,
failure,
)
import Data.Text (Text)
import Text.Megaparsec
( (<|>),
eof,
label,
manyTill,
optional,
)
import Prelude
( ($),
(.),
)
scalarTypeDefinition ::
Parse (Value s) =>
Maybe Description ->
Parser (TypeDefinition ANY s)
scalarTypeDefinition typeDescription = label "ScalarTypeDefinition" $ do
typeName <- typeDeclaration "scalar"
typeDirectives <- optionalDirectives
pure
TypeDefinition
{ typeFingerprint = DataFingerprint typeName [],
typeContent = DataScalar $ ScalarDefinition pure,
..
}
objectTypeDefinition ::
Parse (Value s) =>
Maybe Description ->
Parser (TypeDefinition OUT s)
objectTypeDefinition typeDescription = label "ObjectTypeDefinition" $ do
typeName <- typeDeclaration "type"
objectImplements <- optionalImplementsInterfaces
typeDirectives <- optionalDirectives
objectFields <- fieldsDefinition
pure
TypeDefinition
{ typeFingerprint = DataFingerprint typeName [],
typeContent = DataObject {objectImplements, objectFields},
..
}
optionalImplementsInterfaces :: Parser [TypeName]
optionalImplementsInterfaces = implements <|> pure []
where
implements =
label "ImplementsInterfaces" $ keyword "implements" *> sepByAnd parseTypeName
interfaceTypeDefinition ::
Parse (Value s) =>
Maybe Description ->
Parser (TypeDefinition OUT s)
interfaceTypeDefinition typeDescription = label "InterfaceTypeDefinition" $ do
typeName <- typeDeclaration "interface"
typeDirectives <- optionalDirectives
typeContent <- DataInterface <$> fieldsDefinition
pure
TypeDefinition
{ typeFingerprint = DataFingerprint typeName [],
..
}
unionTypeDefinition ::
Parse (Value s) =>
Maybe Description ->
Parser (TypeDefinition OUT s)
unionTypeDefinition typeDescription = label "UnionTypeDefinition" $ do
typeName <- typeDeclaration "union"
typeDirectives <- optionalDirectives
typeContent <- DataUnion <$> unionMemberTypes
pure
TypeDefinition
{ typeFingerprint = DataFingerprint typeName [],
..
}
where
unionMemberTypes =
symbol '='
*> pipe (mkUnionMember <$> parseTypeName)
enumTypeDefinition ::
Parse (Value s) =>
Maybe Description ->
Parser (TypeDefinition ANY s)
enumTypeDefinition typeDescription = label "EnumTypeDefinition" $ do
typeName <- typeDeclaration "enum"
typeDirectives <- optionalDirectives
typeContent <- DataEnum <$> collection enumValueDefinition
pure
TypeDefinition
{ typeFingerprint = DataFingerprint typeName [],
..
}
inputObjectTypeDefinition ::
Parse (Value s) =>
Maybe Description ->
Parser (TypeDefinition IN s)
inputObjectTypeDefinition typeDescription =
label "InputObjectTypeDefinition" $ do
typeName <- typeDeclaration "input"
typeDirectives <- optionalDirectives
typeContent <- DataInputObject <$> inputFieldsDefinition
pure
TypeDefinition
{ typeFingerprint = DataFingerprint typeName [],
..
}
parseDirectiveDefinition ::
Maybe Description ->
Parser RawTypeDefinition
parseDirectiveDefinition directiveDefinitionDescription = label "DirectiveDefinition" $ do
keyword "directive"
symbol '@'
directiveDefinitionName <- parseName
directiveDefinitionArgs <- optionalCollection argumentsDefinition
_ <- optional (keyword "repeatable")
keyword "on"
directiveDefinitionLocations <- pipe parseDirectiveLocation
pure
$ RawDirectiveDefinition
$ DirectiveDefinition
{ directiveDefinitionName,
directiveDefinitionDescription,
directiveDefinitionLocations,
directiveDefinitionArgs
}
parseSchemaDefinition :: Maybe Description -> Parser RawTypeDefinition
parseSchemaDefinition _schemaDescription = label "SchemaDefinition" $ do
keyword "schema"
schemaDirectives <- optionalDirectives
unSchemaDefinition <- setOf parseRootOperationTypeDefinition
pure
$ RawSchemaDefinition
$ SchemaDefinition {schemaDirectives, unSchemaDefinition}
parseRootOperationTypeDefinition :: Parser RootOperationTypeDefinition
parseRootOperationTypeDefinition = do
operationType <- parseOperationType
symbol ':'
RootOperationTypeDefinition operationType <$> parseTypeName
parseTypeSystemUnit ::
Parser RawTypeDefinition
parseTypeSystemUnit =
label "TypeDefinition" $
do
description <- optDescription
types description
<|> parseSchemaDefinition description
<|> parseDirectiveDefinition description
where
types description =
RawTypeDefinition
<$> ( (toAny <$> inputObjectTypeDefinition description)
<|> (toAny <$> unionTypeDefinition description)
<|> enumTypeDefinition description
<|> scalarTypeDefinition description
<|> (toAny <$> objectTypeDefinition description)
<|> (toAny <$> interfaceTypeDefinition description)
)
typePartition ::
[RawTypeDefinition] ->
( [SchemaDefinition],
[TypeDefinition ANY CONST],
[DirectiveDefinition CONST]
)
typePartition = foldr split ([], [], [])
split ::
RawTypeDefinition ->
( [SchemaDefinition],
[TypeDefinition ANY CONST],
[DirectiveDefinition CONST]
) ->
( [SchemaDefinition],
[TypeDefinition ANY CONST],
[DirectiveDefinition CONST]
)
split (RawSchemaDefinition schema) (schemas, types, dirs) = (schema : schemas, types, dirs)
split (RawTypeDefinition ty) (schemas, types, dirs) = (schemas, ty : types, dirs)
split (RawDirectiveDefinition dir) (schemas, types, dirs) = (schemas, types, dir : dirs)
withSchemaDefinition ::
( [SchemaDefinition],
[TypeDefinition ANY s],
[DirectiveDefinition CONST]
) ->
Eventless
(Maybe SchemaDefinition, [TypeDefinition ANY s], [DirectiveDefinition CONST])
withSchemaDefinition ([], t, dirs) = pure (Nothing, t, dirs)
withSchemaDefinition ([x], t, dirs) = pure (Just x, t, dirs)
withSchemaDefinition (_ : xs, _, _) = failure (fmap nameCollision xs)
parseTypeSystemDefinition :: Parser [RawTypeDefinition]
parseTypeSystemDefinition = label "TypeSystemDefinitions" $ do
ignoredTokens
manyTill parseTypeSystemUnit eof
typeSystemDefinition ::
Text ->
Eventless
( Maybe SchemaDefinition,
[TypeDefinition ANY CONST],
[DirectiveDefinition CONST]
)
typeSystemDefinition =
processParser parseTypeSystemDefinition
>=> withSchemaDefinition . typePartition
parseTypeDefinitions :: Text -> Eventless [TypeDefinition ANY CONST]
parseTypeDefinitions = fmap snd3 . typeSystemDefinition
snd3 :: (a, b, c) -> b
snd3 (_, x, _) = x
parseSchema ::
Text ->
Eventless (Schema CONST)
parseSchema =
typeSystemDefinition
>=> buildSchema