Syntax.hs

{-# LANGUAGE OverloadedStrings #-}

module Hydra.Impl.Haskell.Sources.Ext.Graphql.Syntax where

import Hydra.All
import Hydra.Impl.Haskell.Dsl.Grammars
import Hydra.Util.GrammarToModule
import qualified Hydra.Impl.Haskell.Dsl.Standard as Standard


and_ = terminal "&"
at_ = terminal "@"
bang_ = terminal "!"
colon_ = terminal ":"
directive_ = terminal "directive"
dollar_ = terminal "$"
ellipsis_ = terminal "..."
enum_ = terminal "enum"
equal_ = terminal "="
extend_ = terminal "extend"
false_ = terminal "false"
implements_ = terminal "implements"
input_ = terminal "input"
interface_ = terminal "interface"
lbracket_ = terminal "["
lcurly_ = terminal "{"
lparen_ = terminal "("
null_ = terminal "null"
on_ = terminal "on"
or_ = terminal "or"
rbracket_ = terminal "]"
rcurly_ = terminal "}"
repeatable_ = terminal "repeatable"
rparen_ = terminal ")"
scalar_ = terminal "scalar"
schema_ = terminal "schema"
true_ = terminal "true"
type_ = terminal "type"
union_ = terminal "union"

descriptionOpt = opt"Description"
directivesConst = "Directives" -- Directives_[Const]
directivesConstOpt = opt"Directives" -- Directives_[Const]opt

graphqlSyntaxModule :: Module Meta
graphqlSyntaxModule = grammarToModule ns graphqlGrammar $
    Just ("A GraphQL model. Based on the (extended) BNF at:\n" ++
      "  https://spec.graphql.org/draft/#sec-Appendix-Grammar-Summary")
  where
    ns = Namespace "hydra/ext/graphql/syntax"

graphqlGrammar :: Grammar
graphqlGrammar = Grammar $ tokenDefinitions ++ documentDefinitions

tokenDefinitions :: [Production]
tokenDefinitions = [
  define "Name"        [regex "[A-Za-z][A-Za-z0-9]*"],
  define "IntValue"    [regex "-?(0|[1-9][0-9]*)"],
  define "FloatValue"  [regex "-?(0|[1-9][0-9]*)([.][0-9]+|[eE][+-]?[0-9]+)"],
  define "StringValue" [regex "[\"].*[\"]"]] -- TODO: the actual expression includes Unicode escape sequences

documentDefinitions :: [Production]
documentDefinitions = [
  define "Document" [
    star"Definition"],

  define "Definition" [
    "executable">: "ExecutableDefinition",
    "typeSystem">: "TypeSystemDefinitionOrExtension"],

  define "ExecutableDocument" [
    star"ExecutableDefinition"],

  define "ExecutableDefinition" [
    "operation">: "OperationDefinition",
    "fragment">: "FragmentDefinition"],

  define "OperationDefinition" [
    list["OperationType", opt"Name", opt"VariablesDefinition", opt"Directives", "SelectionSet"],
    "SelectionSet"],

  define "OperationType" [
    terminal "query",
    terminal "mutation",
    terminal "subscription"],

  define "SelectionSet" [
    list[lcurly_, star"Selection", rcurly_]],

  define "Selection" [
    "Field",
    "FragmentSpread",
    "InlineFragment"],

  define "Field" [
    list[opt"Alias", "Name", opt"Arguments", opt"Directives", opt"SelectionSet"]],

  define "Alias" [
    "Name", colon_],

  define "Arguments"{- [Const] -} [
    list[lparen_, star"Argument"{- [?Const] -}, rparen_]],

  define "Argument"{- [Const] -} [
    list["Name", colon_, "Value"{- [?Const] -}]],

  define "FragmentSpread" [
    list[ellipsis_, "FragmentName", opt"Directives"]],

  define "InlineFragment" [
    list[ellipsis_, opt"TypeCondition", opt"Directives", "SelectionSet"]],

  define "FragmentDefinition" [
    list[terminal "fragment", "FragmentName", "TypeCondition", opt"Directives", "SelectionSet"]],

  define "FragmentName" [
    "Name" {- but not on_ -}],

  define "TypeCondition" [
    on_, "NamedType"],

  define "Value"{- [Const] -} [
    {- [if not Const] -} "Variable",
    "int">: "IntValue",
    "float">: "FloatValue",
    "string">: "StringValue",
    "boolean">: "BooleanValue",
    "null">: "NullValue",
    "enum">: "EnumValue",
    "list">: "ListValue"{- [?Const] -},
    "object">: "ObjectValue"{- [?Const] -}],

  define "BooleanValue" [
    true_,
    false_],

  define "NullValue" [
    null_],

  define "EnumValue" [
    list["Name" {- but not true_ or false_ or null_ -}]],

  define "ListValue"{- [Const] -} [
    list[lbracket_, rbracket_],
    list[lbracket_, star"Value"{- [?Const] -}]],

  define "ObjectValue"{- [Const] -} [
    list[lcurly_, rcurly_],
    list[star"ObjectField"{- [?Const] -}]],

  define "ObjectField"{- [Const] -} [
    list["Name", colon_, "Value"{- [?Const] -}]],

  define "VariablesDefinition" [
    list["Variable", colon_, "Type", opt"DefaultValue", directivesConstOpt]],

  define "Variable" [
    "Name"],

  define "DefaultValue" [
    list[equal_, "Value"{- [Const] -}]],

  define "Type" [
    "named">: "NamedType",
    "list">: "ListType",
    "nonNull">: "NonNullType"],

  define "NamedType" [
    "Name"],

  define "ListType" [
    list[lbracket_, "Type", rbracket_]],

  define "NonNullType" [
    "named">: list["NamedType", bang_],
    "list">: list["ListType", bang_]],

  define "Directives"{- [Const] -} [
    star("Directive"{- [?Const] -})],

  define "Directive"{- [Const] -} [
    list[at_, "Name", opt("Arguments"{- [?Const] -})]],

  define "TypeSystemDocment" [
    star"TypeSystemDefinition"],

  define "TypeSystemDefinition" [
    "schema">: "SchemaDefinition",
    "type">: "TypeDefinition",
    "directive">: "DirectiveDefinition"],

  define "TypeSystemExtensionDocument" [
    star"TypeSystemDefinitionOrExtension"],

  define "TypeSystemDefinitionOrExtension" [
    "definition">: "TypeSystemDefinition",
    "extension">: "TypeSystemExtension"],

  define "TypeSystemExtension" [
    "schema">: "SchemaExtension",
    "type">: "TypeExtension"],

  define "SchemaDefinition" [
    list[descriptionOpt, schema_, directivesConstOpt, lcurly_, "RootOperationTypeDefinition", rcurly_]],

  define "SchemaExtension" [
    list[extend_, schema_, directivesConstOpt, lcurly_, "RootOperationTypeDefinition", rcurly_],
    list[extend_, schema_, directivesConst {- [lookahead != lcurly_] -}]],

  define "RootOperationTypeDefinition" [
    list["OperationType", colon_, "NamedType"]],

  define "Description" [
    "StringValue"],

  define "TypeDefinition" [
    "scalar">: "ScalarTypeDefinition",
    "object">: "ObjectTypeDefinition",
    "interface">: "InterfaceTypeDefinition",
    "union">: "UnionTypeDefinition",
    "enum">: "EnumTypeDefinition",
    "inputObject">: "InputObjectTypeDefinition"],

  define "TypeExtension" [
    "scalar">: "ScalarTypeExtension",
    "object">: "ObjectTypeExtension",
    "interface">: "InterfaceTypeExtension",
    "union">: "UnionTypeExtension",
    "enum">: "EnumTypeExtension",
    "inputObject">: "InputObjectTypeExtension"],

  define "ScalarTypeDefinition" [
    list[descriptionOpt, scalar_, "Name", directivesConstOpt ]],

  define "ScalarTypeExtension" [
    list[extend_, scalar_, "Name", directivesConst]],

  define "ObjectTypeDefinition" [
    list[descriptionOpt, type_, "Name", opt"ImplementsInterfaces", directivesConstOpt, "FieldsDefinition"],
    list[descriptionOpt, type_, "Name", opt"ImplementsInterfaces", directivesConstOpt {- [lookahead != lcurly_] -}]],

  define "ObjectTypeExtension" [
    list[extend_, type_, "Name", opt"ImplementsInterfaces", directivesConstOpt, "FieldsDefinition"],
    list[extend_, type_, "Name", opt"ImplementsInterfaces", directivesConstOpt {- [lookahead != lcurly_] -}],
    list[extend_, type_, "Name", "ImplementsInterfaces" {- [lookahead != lcurly_] -}]],

  define "ImplementsInterfaces" [
    list["ImplementsInterfaces", and_, "NamedType"],
    list[implements_, opt(and_), "NamedType"]],

  define "FieldsDefinition" [
    list[lcurly_, star"FieldDefinition", rcurly_]],

  define "FieldDefinition" [
    list[descriptionOpt, "Name", opt"ArgumentsDefinition", colon_, "Type", directivesConstOpt]],

  define "ArgumentsDefinition" [
    list[lparen_, star"InputValueDefinition", rparen_]],

  define "InputValueDefinition" [
    list[descriptionOpt, "Name", colon_, "Type", opt"DefaultValue", directivesConstOpt]],

  define "InterfaceTypeDefinition" [
    list[descriptionOpt, interface_, "Name", opt"ImplementsInterfaces", directivesConstOpt, "FieldsDefinition"],
    list[descriptionOpt, interface_, "Name", "ImplementsInterfaces", directivesConstOpt {- [lookahead != lcurly_] -}]],

  define "InterfaceTypeExtension" [
    list[extend_, interface_, "Name", opt"ImplementsInterfaces", directivesConstOpt, "FieldsDefinition"],
    list[extend_, interface_, "Name", opt"ImplementsInterfaces", directivesConst {- [lookahead != lcurly_] -}],
    list[extend_, interface_, "Name", "ImplementsInterfaces" {- [lookahead != lcurly_] -}]],

  define "UnionTypeDefinition" [
    list[descriptionOpt, union_, "Name", directivesConstOpt, opt"UnionMemberTypes"]],

  define "UnionMemberTypes" [
    list["UnionMemberTypes", or_, "NamedType"],
    list[opt(or_), "NamedType"]],

  define "UnionTypeExtension" [
    list[extend_, union_, "Name", directivesConstOpt, "UnionMemberTypes"],
    list[extend_, union_, "Name", directivesConst]],

  define "EnumTypeDefinition" [
    list[descriptionOpt, enum_, "Name", directivesConstOpt, "EnumValuesDefinition"],
    list[descriptionOpt, enum_, directivesConstOpt {- [lookahead != lcurly_] -}]],

  define "EnumValuesDefinition" [
    list[lcurly_, star"EnumValueDefinition", rcurly_]],

  define "EnumValueDefinition" [
    list[descriptionOpt, "EnumValue", directivesConstOpt]],

  define "EnumTypeExtension" [
    list[extend_, enum_, "Name", directivesConstOpt, "EnumValuesDefinition"],
    list[extend_, enum_, "Name", directivesConst {- [lookahead != lcurly_] -}]],

  define "InputObjectTypeDefinition" [
    list[descriptionOpt, input_, "Name", directivesConstOpt, "InputFieldsDefinition"],
    list[descriptionOpt, input_, "Name", directivesConstOpt {- [lookahead != lcurly_] -}]],

  define "InputFieldsDefinition" [
    list[lcurly_, star"InputValueDefinition", rcurly_]],

  define "InputObjectTypeExtension" [
    list[extend_, input_, "Name", directivesConstOpt, "InputFieldsDefinition"],
    list[extend_, input_, "Name", directivesConst {- [lookahead != lcurly_] -}]],

  define "DirectiveDefinition" [
    list[descriptionOpt, directive_, at_, "Name", opt"ArgumentsDefinition", opt(repeatable_), on_, "DirectiveLocations"]],

  define "DirectiveLocations" [
    list["DirectiveLocations", or_, "DirectiveLocation"],
    list[opt(or_), "DirectiveLocation"]],

  define "DirectiveLocation" [
    "executable">: "ExecutableDirectiveLocation",
    "typeSystem">: "TypeSystemDirectiveLocation"],

  define "ExecutableDirectiveLocation" $ terminal <$> [
    "QUERY",
    "MUTATION",
    "SUBSCRIPTION",
    "FIELD",
    "FRAGMENT_DEFINITION",
    "FRAGMENT_SPREAD",
    "INLINE_FRAGMENT",
    "VARIABLE_DEFINITION"],

  define "TypeSystemDirectiveLocation" $ terminal <$> [
    "SCHEMA",
    "SCALAR",
    "OBJECT",
    "FIELD_DEFINITION",
    "ARGUMENT_DEFINITION",
    "INTERFACE",
    "UNION",
    "ENUM",
    "ENUM_VALUE",
    "INPUT_OBJECT",
    "INPUT_FIELD_DEFINITION"]]