Add definition module

This commit is contained in:
Eugen Wissner 2019-12-26 13:00:47 +01:00
parent e3a495a778
commit 56d88310df
8 changed files with 164 additions and 30 deletions

View File

@ -7,12 +7,13 @@ and this project adheres to
[Haskell Package Versioning Policy](https://pvp.haskell.org/).
## [Unreleased]
### Added
- AST for the GraphQL schema.
### Changed
- Rename `AST.Definition` into `AST.ExecutableDefinition`.
TypeSystemDefinition and TypeSystemExtension can also be definitions.
- Define `AST.Definition` as
`newtype Definition = ExecutableDefinition ExecutableDefinition` for now. It
should be soon extended to contain missing definition types.
`AST.TypeSystemDefinition` and `AST.TypeSystemExtension` can also be
definitions.
### Removed
- `AST.Field`, `AST.InlineFragment` and `AST.FragmentSpread`.

View File

@ -5,10 +5,8 @@
module Language.GraphQL.AST
( Alias
, Argument(..)
, Definition(..)
, Directive(..)
, Document
, ExecutableDefinition(..)
, Directive(..)
, FragmentDefinition(..)
, Name
, NonNullType(..)
@ -28,15 +26,6 @@ import Data.Int (Int32)
import Data.List.NonEmpty (NonEmpty)
import Data.Text (Text)
-- * Document
-- | GraphQL document.
type Document = NonEmpty Definition
-- | All kinds of definitions that can occur in a GraphQL document.
newtype Definition = ExecutableDefinition ExecutableDefinition
deriving (Eq, Show)
-- | Name
type Name = Text
@ -74,8 +63,6 @@ type SelectionSet = NonEmpty Selection
-- | Field selection.
type SelectionSetOpt = [Selection]
-- * Field
-- | Single GraphQL field.
--
-- The only required property of a field is its name. Optionally it can also

View File

@ -0,0 +1,34 @@
module Language.GraphQL.AST.DirectiveLocation
( DirectiveLocation
, ExecutableDirectiveLocation
, TypeSystemDirectiveLocation
) where
data DirectiveLocation
= ExecutableDirectiveLocation ExecutableDirectiveLocation
| TypeSystemDirectiveLocation TypeSystemDirectiveLocation
deriving (Eq, Show)
data ExecutableDirectiveLocation
= Query
| Mutation
| Subscription
| Field
| FragmentDefinition
| FragmentSpread
| InlineFragment
deriving (Eq, Show)
data TypeSystemDirectiveLocation
= Schema
| Scalar
| Object
| FieldDefinition
| ArgumentDefinition
| Interface
| Union
| Enum
| EnumValue
| InputObject
| InputFieldDefinition
deriving (Eq, Show)

View File

@ -0,0 +1,107 @@
-- | This module defines data structures representing a GraphQL document.
module Language.GraphQL.AST.Document
( Definition(..)
, Document
, ExecutableDefinition(..)
) where
import Data.List.NonEmpty (NonEmpty)
import Data.Text (Text)
import Language.GraphQL.AST
( ExecutableDefinition(..)
, Directive
, Name
, OperationType
, Type
, Value
)
import Language.GraphQL.AST.DirectiveLocation
-- | GraphQL document.
type Document = NonEmpty Definition
type NamedType = Name
newtype Description = Description (Maybe Text)
deriving (Eq, Show)
type RootOperationTypeDefinitions = NonEmpty RootOperationTypeDefinition
data RootOperationTypeDefinition
= RootOperationTypeDefinition OperationType NamedType
deriving (Eq, Show)
-- | All kinds of definitions that can occur in a GraphQL document.
data Definition
= ExecutableDefinition ExecutableDefinition
| TypeSystemDefinition TypeSystemDefinition
| TypeSystemExtension TypeSystemExtension
deriving (Eq, Show)
data TypeSystemDefinition
= SchemaDefinition [Directive] RootOperationTypeDefinitions
| TypeDefinition TypeDefinition
| DirectiveDefinition Description Name ArgumentsDefinition DirectiveLocation
deriving (Eq, Show)
data SchemaExtension
= SchemaOperationExtension [Directive] RootOperationTypeDefinitions
| SchemaDirectiveExtension (NonEmpty Directive)
deriving (Eq, Show)
data TypeSystemExtension
= SchemaExtension SchemaExtension
| TypeExtension TypeExtension
deriving (Eq, Show)
newtype ImplementsInterfaces = ImplementsInterfaces (NonEmpty NamedType)
deriving (Eq, Show)
newtype ImplementsInterfacesOpt = ImplementsInterfacesOpt [NamedType]
deriving (Eq, Show)
newtype UnionMemberTypes = UnionMemberTypes (NonEmpty NamedType)
deriving (Eq, Show)
newtype UnionMemberTypesOpt = UnionMemberTypesOpt [NamedType]
deriving (Eq, Show)
newtype InputFieldsDefinition = InputFieldsDefinition (NonEmpty InputValueDefinition)
deriving (Eq, Show)
newtype InputFieldsDefinitionOpt = InputFieldsDefinitionOpt [InputValueDefinition]
deriving (Eq, Show)
data InputValueDefinition
= InputValueDefinition Description Name Type (Maybe Value) [Directive]
deriving (Eq, Show)
newtype ArgumentsDefinition = ArgumentsDefinition [InputValueDefinition]
deriving (Eq, Show)
data EnumValueDefinition = EnumValueDefinition Description Name [Directive]
deriving (Eq, Show)
data FieldDefinition = FieldDefinition Description Name ArgumentsDefinition Type
deriving (Eq, Show)
data TypeDefinition
= ScalarTypeDefinition Description Name [Directive]
| ObjectTypeDefinition Description Name ImplementsInterfacesOpt [Directive] [FieldDefinition]
| InterfaceTypeDefinition Description Name [Directive] [FieldDefinition]
| UnionTypeDefinition Description Name [Directive] UnionMemberTypesOpt
| EnumTypeDefinition Description Name [Directive] [EnumValueDefinition]
| InputObjectTypeDefinition Description Name [Directive] InputFieldsDefinitionOpt
deriving (Eq, Show)
data TypeExtension
= ScalarTypeExtension Name (NonEmpty Directive)
| ObjectTypeFieldsDefinitionExtension Name ImplementsInterfacesOpt [Directive] (NonEmpty FieldDefinition)
| ObjectTypeDirectivesExtension Name ImplementsInterfacesOpt (NonEmpty Directive)
| ObjectTypeImplementsInterfacesExtension Name ImplementsInterfaces
| InterfaceTypeFieldsDefinitionExtension Name [Directive] (NonEmpty FieldDefinition)
| InterfaceTypeDirectivesExtension Name (NonEmpty Directive)
| UnionTypeUnionMemberTypesExtension Name [Directive] UnionMemberTypes
| UnionDirectivesExtension Name (NonEmpty Directive)
| EnumTypeEnumValuesDefinitionExtension Name [Directive] (NonEmpty EnumValueDefinition)
| EnumTypeDirectivesExtension Name (NonEmpty Directive)
| InputObjectTypeInputFieldsDefinitionExtension Name [Directive] InputFieldsDefinition
| InputObjectTypeDirectivesExtension Name (NonEmpty Directive)
deriving (Eq, Show)

View File

@ -26,6 +26,7 @@ import qualified Data.Text.Lazy.Builder as Builder
import Data.Text.Lazy.Builder.Int (decimal, hexadecimal)
import Data.Text.Lazy.Builder.RealFloat (realFloat)
import qualified Language.GraphQL.AST as Full
import Language.GraphQL.AST.Document
-- | Instructs the encoder whether the GraphQL document should be minified or
-- pretty printed.
@ -43,17 +44,18 @@ pretty = Pretty 0
minified :: Formatter
minified = Minified
-- | Converts a 'Full.Document' into a string.
document :: Formatter -> Full.Document -> Lazy.Text
-- | Converts a Document' into a string.
document :: Formatter -> Document -> Lazy.Text
document formatter defs
| Pretty _ <- formatter = Lazy.Text.intercalate "\n" encodeDocument
| Minified <-formatter = Lazy.Text.snoc (mconcat encodeDocument) '\n'
where
encodeDocument = foldr executableDefinition [] defs
executableDefinition (Full.ExecutableDefinition x) acc = definition formatter x : acc
executableDefinition (ExecutableDefinition x) acc = definition formatter x : acc
executableDefinition _ acc = acc
-- | Converts a 'Full.Definition' into a string.
definition :: Formatter -> Full.ExecutableDefinition -> Lazy.Text
definition :: Formatter -> ExecutableDefinition -> Lazy.Text
definition formatter x
| Pretty _ <- formatter = Lazy.Text.snoc (encodeDefinition x) '\n'
| Minified <- formatter = encodeDefinition x

View File

@ -9,14 +9,15 @@ module Language.GraphQL.AST.Parser
import Control.Applicative (Alternative(..), optional)
import Data.List.NonEmpty (NonEmpty(..))
import Language.GraphQL.AST
import qualified Language.GraphQL.AST.Document as Document
import Language.GraphQL.AST.Lexer
import Text.Megaparsec (lookAhead, option, try, (<?>))
-- | Parser for the GraphQL documents.
document :: Parser Document
document :: Parser Document.Document
document = unicodeBOM
>> spaceConsumer
>> lexeme (manyNE $ ExecutableDefinition <$> definition)
>> lexeme (manyNE $ Document.ExecutableDefinition <$> definition)
definition :: Parser ExecutableDefinition
definition = DefinitionOperation <$> operationDefinition

View File

@ -13,7 +13,7 @@ import Data.List.NonEmpty (NonEmpty(..))
import qualified Data.List.NonEmpty as NE
import Data.Text (Text)
import qualified Data.Text as Text
import qualified Language.GraphQL.AST as AST
import Language.GraphQL.AST.Document
import qualified Language.GraphQL.AST.Core as AST.Core
import qualified Language.GraphQL.Execute.Transform as Transform
import Language.GraphQL.Error
@ -27,7 +27,7 @@ import qualified Language.GraphQL.Schema as Schema
execute :: MonadIO m
=> NonEmpty (Schema.Resolver m) -- ^ Resolvers.
-> Schema.Subs -- ^ Variable substitution function.
-> AST.Document -- @GraphQL@ document.
-> Document -- @GraphQL@ document.
-> m Aeson.Value
execute schema subs doc =
maybe transformError (document schema Nothing) $ Transform.document subs doc
@ -44,7 +44,7 @@ executeWithName :: MonadIO m
=> NonEmpty (Schema.Resolver m) -- ^ Resolvers
-> Text -- ^ Operation name.
-> Schema.Subs -- ^ Variable substitution function.
-> AST.Document -- ^ @GraphQL@ Document.
-> Document -- ^ @GraphQL@ Document.
-> m Aeson.Value
executeWithName schema name subs doc =
maybe transformError (document schema $ Just name) $ Transform.document subs doc

View File

@ -19,6 +19,7 @@ import qualified Data.List.NonEmpty as NonEmpty
import Data.Sequence (Seq, (<|), (><))
import qualified Language.GraphQL.AST as Full
import qualified Language.GraphQL.AST.Core as Core
import Language.GraphQL.AST.Document (Definition(..), Document)
import qualified Language.GraphQL.Schema as Schema
import qualified Language.GraphQL.Type.Directive as Directive
@ -35,18 +36,19 @@ liftJust = lift . lift . Just
-- | Rewrites the original syntax tree into an intermediate representation used
-- for query execution.
document :: Schema.Subs -> Full.Document -> Maybe Core.Document
document :: Schema.Subs -> Document -> Maybe Core.Document
document subs document' =
flip runReaderT subs
$ evalStateT (collectFragments >> operations operationDefinitions)
$ Replacement HashMap.empty fragmentTable
where
(fragmentTable, operationDefinitions) = foldr defragment mempty document'
defragment (Full.ExecutableDefinition (Full.DefinitionOperation definition)) acc =
defragment (ExecutableDefinition (Full.DefinitionOperation definition)) acc =
(definition :) <$> acc
defragment (Full.ExecutableDefinition (Full.DefinitionFragment definition)) acc =
defragment (ExecutableDefinition (Full.DefinitionFragment definition)) acc =
let (Full.FragmentDefinition name _ _ _) = definition
in first (HashMap.insert name definition) acc
defragment _ acc = acc
-- * Operation