graphql/src/Language/GraphQL/AST/Parser.hs

{-# LANGUAGE ExplicitForAll #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}

-- | @GraphQL@ document parser.
module Language.GraphQL.AST.Parser
    ( document
    ) where

import Control.Applicative (Alternative(..), liftA2, optional)
import Control.Applicative.Combinators (sepBy1)
import qualified Control.Applicative.Combinators.NonEmpty as NonEmpty
import Data.List.NonEmpty (NonEmpty(..))
import Data.Text (Text)
import qualified Language.GraphQL.AST.DirectiveLocation as Directive
import Language.GraphQL.AST.DirectiveLocation
    ( DirectiveLocation
    , ExecutableDirectiveLocation
    , TypeSystemDirectiveLocation
    )
import qualified Language.GraphQL.AST.Document as Full
import Language.GraphQL.AST.Lexer
import Text.Megaparsec
    ( MonadParsec(..)
    , SourcePos(..)
    , getSourcePos
    , lookAhead
    , option
    , try
    , unPos
    , (<?>)
    )

-- | Parser for the GraphQL documents.
document :: Parser Full.Document
document = unicodeBOM
    *> spaceConsumer
    *> lexeme (NonEmpty.some definition)

definition :: Parser Full.Definition
definition = Full.ExecutableDefinition <$> executableDefinition
    <|> typeSystemDefinition'
    <|> typeSystemExtension'
    <?> "Definition"
  where
    typeSystemDefinition' = do
        location <- getLocation
        definition' <- typeSystemDefinition
        pure $ Full.TypeSystemDefinition definition' location
    typeSystemExtension' = do
        location <- getLocation
        definition' <- typeSystemExtension
        pure $ Full.TypeSystemExtension definition' location

getLocation :: Parser Full.Location
getLocation = fromSourcePosition <$> getSourcePos
  where
    fromSourcePosition SourcePos{..} =
        Full.Location (wordFromPosition sourceLine) (wordFromPosition sourceColumn)
    wordFromPosition = fromIntegral . unPos

executableDefinition :: Parser Full.ExecutableDefinition
executableDefinition = Full.DefinitionOperation <$> operationDefinition
    <|> Full.DefinitionFragment  <$> fragmentDefinition
    <?> "ExecutableDefinition"

typeSystemDefinition :: Parser Full.TypeSystemDefinition
typeSystemDefinition = schemaDefinition
    <|> typeSystemDefinitionWithDescription
    <?> "TypeSystemDefinition"
  where
    typeSystemDefinitionWithDescription = description
        >>= liftA2 (<|>) typeDefinition' directiveDefinition
    typeDefinition' description' = Full.TypeDefinition
        <$> typeDefinition description'

typeSystemExtension :: Parser Full.TypeSystemExtension
typeSystemExtension = Full.SchemaExtension <$> schemaExtension
    <|> Full.TypeExtension <$> typeExtension
    <?> "TypeSystemExtension"

directiveDefinition :: Full.Description -> Parser Full.TypeSystemDefinition
directiveDefinition description' = Full.DirectiveDefinition description'
    <$ symbol "directive"
    <* at
    <*> name
    <*> argumentsDefinition
    <* symbol "on"
    <*> directiveLocations
    <?> "DirectiveDefinition"

directiveLocations :: Parser (NonEmpty DirectiveLocation)
directiveLocations = optional pipe
    *> directiveLocation `NonEmpty.sepBy1` pipe
    <?> "DirectiveLocations"

directiveLocation :: Parser DirectiveLocation
directiveLocation
    = Directive.ExecutableDirectiveLocation <$> executableDirectiveLocation
    <|> Directive.TypeSystemDirectiveLocation <$> typeSystemDirectiveLocation
    <?> "DirectiveLocation"

executableDirectiveLocation :: Parser ExecutableDirectiveLocation
executableDirectiveLocation = Directive.Query <$ symbol "QUERY"
    <|> Directive.Mutation <$ symbol "MUTATION"
    <|> Directive.Subscription <$ symbol "SUBSCRIPTION"
    <|> Directive.Field <$ symbol "FIELD"
    <|> Directive.FragmentDefinition <$ "FRAGMENT_DEFINITION"
    <|> Directive.FragmentSpread <$ "FRAGMENT_SPREAD"
    <|> Directive.InlineFragment <$ "INLINE_FRAGMENT"
    <?> "ExecutableDirectiveLocation"

typeSystemDirectiveLocation :: Parser TypeSystemDirectiveLocation
typeSystemDirectiveLocation = Directive.Schema <$ symbol "SCHEMA"
    <|> Directive.Scalar <$ symbol "SCALAR"
    <|> Directive.Object <$ symbol "OBJECT"
    <|> Directive.FieldDefinition <$ symbol "FIELD_DEFINITION"
    <|> Directive.ArgumentDefinition <$ symbol "ARGUMENT_DEFINITION"
    <|> Directive.Interface <$ symbol "INTERFACE"
    <|> Directive.Union <$ symbol "UNION"
    <|> Directive.Enum <$ symbol "ENUM"
    <|> Directive.EnumValue <$ symbol "ENUM_VALUE"
    <|> Directive.InputObject <$ symbol "INPUT_OBJECT"
    <|> Directive.InputFieldDefinition <$ symbol "INPUT_FIELD_DEFINITION"
    <?> "TypeSystemDirectiveLocation"

typeDefinition :: Full.Description -> Parser Full.TypeDefinition
typeDefinition description' = scalarTypeDefinition description'
    <|> objectTypeDefinition description'
    <|> interfaceTypeDefinition description'
    <|> unionTypeDefinition description'
    <|> enumTypeDefinition description'
    <|> inputObjectTypeDefinition description'
    <?> "TypeDefinition"

typeExtension :: Parser Full.TypeExtension
typeExtension = scalarTypeExtension
    <|> objectTypeExtension
    <|> interfaceTypeExtension
    <|> unionTypeExtension
    <|> enumTypeExtension
    <|> inputObjectTypeExtension
    <?> "TypeExtension"

scalarTypeDefinition :: Full.Description -> Parser Full.TypeDefinition
scalarTypeDefinition description' = Full.ScalarTypeDefinition description'
    <$ symbol "scalar"
    <*> name
    <*> directives
    <?> "ScalarTypeDefinition"

scalarTypeExtension :: Parser Full.TypeExtension
scalarTypeExtension = extend "scalar" "ScalarTypeExtension"
    $ (Full.ScalarTypeExtension <$> name <*> NonEmpty.some directive) :| []

objectTypeDefinition :: Full.Description -> Parser Full.TypeDefinition
objectTypeDefinition description' = Full.ObjectTypeDefinition description'
    <$ symbol "type"
    <*> name
    <*> option (Full.ImplementsInterfaces []) (implementsInterfaces sepBy1)
    <*> directives
    <*> braces (many fieldDefinition)
    <?> "ObjectTypeDefinition"

objectTypeExtension :: Parser Full.TypeExtension
objectTypeExtension = extend "type" "ObjectTypeExtension"
    $ fieldsDefinitionExtension :|
        [ directivesExtension
        , implementsInterfacesExtension
        ]
  where
    fieldsDefinitionExtension = Full.ObjectTypeFieldsDefinitionExtension
        <$> name
        <*> option (Full.ImplementsInterfaces []) (implementsInterfaces sepBy1)
        <*> directives
        <*> braces (NonEmpty.some fieldDefinition)
    directivesExtension = Full.ObjectTypeDirectivesExtension
        <$> name
        <*> option (Full.ImplementsInterfaces []) (implementsInterfaces sepBy1)
        <*> NonEmpty.some directive
    implementsInterfacesExtension = Full.ObjectTypeImplementsInterfacesExtension
        <$> name
        <*> implementsInterfaces NonEmpty.sepBy1

description :: Parser Full.Description
description = Full.Description
    <$> optional stringValue
    <?> "Description"

unionTypeDefinition :: Full.Description -> Parser Full.TypeDefinition
unionTypeDefinition description' = Full.UnionTypeDefinition description'
    <$ symbol "union"
    <*> name
    <*> directives
    <*> option (Full.UnionMemberTypes []) (unionMemberTypes sepBy1)
    <?> "UnionTypeDefinition"

unionTypeExtension :: Parser Full.TypeExtension
unionTypeExtension = extend "union" "UnionTypeExtension"
    $ unionMemberTypesExtension :| [directivesExtension]
  where
    unionMemberTypesExtension = Full.UnionTypeUnionMemberTypesExtension
        <$> name
        <*> directives
        <*> unionMemberTypes NonEmpty.sepBy1
    directivesExtension = Full.UnionTypeDirectivesExtension
        <$> name
        <*> NonEmpty.some directive

unionMemberTypes ::
    Foldable t =>
    (Parser Text -> Parser Text -> Parser (t Full.NamedType)) ->
    Parser (Full.UnionMemberTypes t)
unionMemberTypes sepBy' = Full.UnionMemberTypes
    <$ equals
    <* optional pipe
    <*> name `sepBy'` pipe
    <?> "UnionMemberTypes"

interfaceTypeDefinition :: Full.Description -> Parser Full.TypeDefinition
interfaceTypeDefinition description' = Full.InterfaceTypeDefinition description'
    <$ symbol "interface"
    <*> name
    <*> directives
    <*> braces (many fieldDefinition)
    <?> "InterfaceTypeDefinition"

interfaceTypeExtension :: Parser Full.TypeExtension
interfaceTypeExtension = extend "interface" "InterfaceTypeExtension"
    $ fieldsDefinitionExtension :| [directivesExtension]
  where
    fieldsDefinitionExtension = Full.InterfaceTypeFieldsDefinitionExtension
        <$> name
        <*> directives
        <*> braces (NonEmpty.some fieldDefinition)
    directivesExtension = Full.InterfaceTypeDirectivesExtension
        <$> name
        <*> NonEmpty.some directive

enumTypeDefinition :: Full.Description -> Parser Full.TypeDefinition
enumTypeDefinition description' = Full.EnumTypeDefinition description'
    <$ symbol "enum"
    <*> name
    <*> directives
    <*> listOptIn braces enumValueDefinition
    <?> "EnumTypeDefinition"

enumTypeExtension :: Parser Full.TypeExtension
enumTypeExtension = extend "enum" "EnumTypeExtension"
    $ enumValuesDefinitionExtension :| [directivesExtension]
  where
    enumValuesDefinitionExtension = Full.EnumTypeEnumValuesDefinitionExtension
        <$> name
        <*> directives
        <*> braces (NonEmpty.some enumValueDefinition)
    directivesExtension = Full.EnumTypeDirectivesExtension
        <$> name
        <*> NonEmpty.some directive

inputObjectTypeDefinition :: Full.Description -> Parser Full.TypeDefinition
inputObjectTypeDefinition description' = Full.InputObjectTypeDefinition description'
    <$ symbol "input"
    <*> name
    <*> directives
    <*> listOptIn braces inputValueDefinition
    <?> "InputObjectTypeDefinition"

inputObjectTypeExtension :: Parser Full.TypeExtension
inputObjectTypeExtension = extend "input" "InputObjectTypeExtension"
    $ inputFieldsDefinitionExtension :| [directivesExtension]
  where
    inputFieldsDefinitionExtension = Full.InputObjectTypeInputFieldsDefinitionExtension
        <$> name
        <*> directives
        <*> braces (NonEmpty.some inputValueDefinition)
    directivesExtension = Full.InputObjectTypeDirectivesExtension
        <$> name
        <*> NonEmpty.some directive

enumValueDefinition :: Parser Full.EnumValueDefinition
enumValueDefinition = Full.EnumValueDefinition
    <$> description
    <*> enumValue
    <*> directives
    <?> "EnumValueDefinition"

implementsInterfaces ::
    Foldable t =>
    (Parser Text -> Parser Text -> Parser (t Full.NamedType)) ->
    Parser (Full.ImplementsInterfaces t)
implementsInterfaces sepBy' = Full.ImplementsInterfaces
    <$ symbol "implements"
    <* optional amp
    <*> name `sepBy'` amp
    <?> "ImplementsInterfaces"

inputValueDefinition :: Parser Full.InputValueDefinition
inputValueDefinition = Full.InputValueDefinition
    <$> description
    <*> name
    <* colon
    <*> type'
    <*> defaultValue
    <*> directives
    <?> "InputValueDefinition"

argumentsDefinition :: Parser Full.ArgumentsDefinition
argumentsDefinition = Full.ArgumentsDefinition
    <$> listOptIn parens inputValueDefinition
    <?> "ArgumentsDefinition"

fieldDefinition :: Parser Full.FieldDefinition
fieldDefinition = Full.FieldDefinition
    <$> description
    <*> name
    <*> argumentsDefinition
    <* colon
    <*> type'
    <*> directives
    <?> "FieldDefinition"

schemaDefinition :: Parser Full.TypeSystemDefinition
schemaDefinition = Full.SchemaDefinition
    <$ symbol "schema"
    <*> directives
    <*> operationTypeDefinitions
    <?> "SchemaDefinition"

operationTypeDefinitions :: Parser (NonEmpty Full.OperationTypeDefinition)
operationTypeDefinitions = braces $ NonEmpty.some operationTypeDefinition

schemaExtension :: Parser Full.SchemaExtension
schemaExtension = extend "schema" "SchemaExtension"
    $ schemaOperationExtension :| [directivesExtension]
  where
    directivesExtension = Full.SchemaDirectivesExtension
        <$> NonEmpty.some directive
    schemaOperationExtension = Full.SchemaOperationExtension
        <$> directives
        <*> operationTypeDefinitions

operationTypeDefinition :: Parser Full.OperationTypeDefinition
operationTypeDefinition = Full.OperationTypeDefinition
    <$> operationType <* colon
    <*> name
    <?> "OperationTypeDefinition"

operationDefinition :: Parser Full.OperationDefinition
operationDefinition = shorthand
    <|> operationDefinition'
    <?> "OperationDefinition"
  where
    shorthand = do
        location <- getLocation
        selectionSet' <- selectionSet
        pure $ Full.SelectionSet selectionSet' location
    operationDefinition' = do
        location <- getLocation
        operationType' <- operationType
        operationName <- optional name
        variableDefinitions' <- variableDefinitions
        directives' <- directives
        selectionSet' <- selectionSet
        pure $ Full.OperationDefinition
            operationType'
            operationName
            variableDefinitions'
            directives'
            selectionSet'
            location

operationType :: Parser Full.OperationType
operationType = Full.Query <$ symbol "query"
    <|> Full.Mutation <$ symbol "mutation"
    <|> Full.Subscription <$ symbol "subscription"
    <?> "OperationType"

selectionSet :: Parser Full.SelectionSet
selectionSet = braces (NonEmpty.some selection) <?> "SelectionSet"

selectionSetOpt :: Parser Full.SelectionSetOpt
selectionSetOpt = listOptIn braces selection <?> "SelectionSet"

selection :: Parser Full.Selection
selection = Full.FieldSelection <$> field
    <|> Full.FragmentSpreadSelection <$> try fragmentSpread
    <|> Full.InlineFragmentSelection <$> inlineFragment
    <?> "Selection"

field :: Parser Full.Field
field = label "Field" $ do
    location <- getLocation
    alias' <- optional alias
    name' <- name
    arguments' <- arguments
    directives' <- directives
    selectionSetOpt' <- selectionSetOpt
    pure $ Full.Field alias' name' arguments' directives' selectionSetOpt' location

alias :: Parser Full.Name
alias = try (name <* colon) <?> "Alias"

arguments :: Parser [Full.Argument]
arguments = listOptIn parens argument <?> "Arguments"

argument :: Parser Full.Argument
argument = label "Argument" $ do
    location <- getLocation
    name' <- name
    colon
    value' <- valueNode value
    pure $ Full.Argument name' value' location

fragmentSpread :: Parser Full.FragmentSpread
fragmentSpread = label "FragmentSpread" $ do
    location <- getLocation
    _ <- spread
    fragmentName' <- fragmentName
    directives' <- directives
    pure $ Full.FragmentSpread fragmentName' directives' location

inlineFragment :: Parser Full.InlineFragment
inlineFragment = label "InlineFragment" $ do
    location <- getLocation
    _ <- spread
    typeCondition' <- optional typeCondition
    directives' <- directives
    selectionSet' <- selectionSet
    pure $ Full.InlineFragment typeCondition' directives' selectionSet' location

fragmentDefinition :: Parser Full.FragmentDefinition
fragmentDefinition =  label "FragmentDefinition" $ do
    location <- getLocation
    _ <- symbol "fragment"
    fragmentName' <- name
    typeCondition' <- typeCondition
    directives' <- directives
    selectionSet' <- selectionSet
    pure $ Full.FragmentDefinition
        fragmentName' typeCondition' directives' selectionSet' location

fragmentName :: Parser Full.Name
fragmentName = but (symbol "on") *> name <?> "FragmentName"

typeCondition :: Parser Full.TypeCondition
typeCondition = symbol "on" *> name <?> "TypeCondition"

valueNode :: forall a. Parser a -> Parser (Full.Node a)
valueNode valueParser = do
    location <- getLocation
    value' <- valueParser
    pure $ Full.Node value' location

value :: Parser Full.Value
value = Full.Variable <$> variable
    <|> Full.Float <$> try float
    <|> Full.Int <$> integer
    <|> Full.Boolean <$> booleanValue
    <|> Full.Null <$  nullValue
    <|> Full.String <$> stringValue
    <|> Full.Enum <$> try enumValue
    <|> Full.List <$> brackets (some value)
    <|> Full.Object <$> braces (some $ objectField value)
    <?> "Value"

constValue :: Parser Full.ConstValue
constValue = Full.ConstFloat <$> try float
    <|> Full.ConstInt <$> integer
    <|> Full.ConstBoolean <$> booleanValue
    <|> Full.ConstNull <$ nullValue
    <|> Full.ConstString <$> stringValue
    <|> Full.ConstEnum <$> try enumValue
    <|> Full.ConstList <$> brackets (some constValue)
    <|> Full.ConstObject <$> braces (some $ objectField constValue)
    <?> "Value"

booleanValue :: Parser Bool
booleanValue = True  <$ symbol "true"
    <|> False <$ symbol "false"
    <?> "BooleanValue"

enumValue :: Parser Full.Name
enumValue = but (symbol "true")
    *> but (symbol "false")
    *> but (symbol "null")
    *> name
    <?> "EnumValue"

stringValue :: Parser Text
stringValue = blockString <|> string <?> "StringValue"

nullValue :: Parser Text
nullValue = symbol "null" <?> "NullValue"

objectField :: Parser a -> Parser (Full.ObjectField a)
objectField valueParser = label "ObjectField" $ do
    location <- getLocation
    fieldName <- name
    colon
    fieldValue <- valueParser
    pure $ Full.ObjectField fieldName fieldValue location

variableDefinitions :: Parser [Full.VariableDefinition]
variableDefinitions = listOptIn parens variableDefinition
    <?> "VariableDefinitions"

variableDefinition :: Parser Full.VariableDefinition
variableDefinition = label "VariableDefinition" $ do
    location <- getLocation
    variableName <- variable
    colon
    variableType <- type'
    variableValue <- defaultValue
    pure $ Full.VariableDefinition variableName variableType variableValue location

variable :: Parser Full.Name
variable = dollar *> name <?> "Variable"

defaultValue :: Parser (Maybe (Full.Node Full.ConstValue))
defaultValue = optional (equals *> valueNode constValue) <?> "DefaultValue"

type' :: Parser Full.Type
type' = try (Full.TypeNonNull <$> nonNullType)
    <|> Full.TypeList <$> brackets type'
    <|> Full.TypeNamed <$> name
    <?> "Type"

nonNullType :: Parser Full.NonNullType
nonNullType = Full.NonNullTypeNamed <$> name <* bang
    <|> Full.NonNullTypeList  <$> brackets type'  <* bang
    <?> "NonNullType"

directives :: Parser [Full.Directive]
directives = many directive <?> "Directives"

directive :: Parser Full.Directive
directive = label "Directive" $ do
    location <- getLocation
    at
    directiveName <- name
    directiveArguments <- arguments
    pure $ Full.Directive directiveName directiveArguments location

listOptIn :: (Parser [a] -> Parser [a]) -> Parser a -> Parser [a]
listOptIn surround = option [] . surround . some

-- Hack to reverse parser success
but :: Parser a -> Parser ()
but pn = False <$ lookAhead pn <|> pure True >>= \case
    False -> empty
    True  -> pure ()