aboutsummaryrefslogtreecommitdiff
path: root/src/Language/GraphQL
diff options
context:
space:
mode:
Diffstat (limited to 'src/Language/GraphQL')
-rw-r--r--src/Language/GraphQL/AST.hs185
-rw-r--r--src/Language/GraphQL/AST/Core.hs12
-rw-r--r--src/Language/GraphQL/AST/DirectiveLocation.hs41
-rw-r--r--src/Language/GraphQL/AST/Document.hs486
-rw-r--r--src/Language/GraphQL/AST/Encoder.hs116
-rw-r--r--src/Language/GraphQL/AST/Lexer.hs42
-rw-r--r--src/Language/GraphQL/AST/Parser.hs435
-rw-r--r--src/Language/GraphQL/Error.hs21
-rw-r--r--src/Language/GraphQL/Execute.hs51
-rw-r--r--src/Language/GraphQL/Execute/Transform.hs107
-rw-r--r--src/Language/GraphQL/Schema.hs121
-rw-r--r--src/Language/GraphQL/Trans.hs25
12 files changed, 1168 insertions, 474 deletions
diff --git a/src/Language/GraphQL/AST.hs b/src/Language/GraphQL/AST.hs
index 44bf969..aba6dfd 100644
--- a/src/Language/GraphQL/AST.hs
+++ b/src/Language/GraphQL/AST.hs
@@ -1,185 +1,6 @@
--- | This module defines an abstract syntax tree for the @GraphQL@ language based on
--- <https://facebook.github.io/graphql/ Facebook's GraphQL Specification>.
---
--- Target AST for Parser.
+-- | Target AST for Parser.
module Language.GraphQL.AST
- ( Alias
- , Argument(..)
- , Definition(..)
- , Directive(..)
- , Document
- , Field(..)
- , FragmentDefinition(..)
- , FragmentSpread(..)
- , InlineFragment(..)
- , Name
- , NonNullType(..)
- , ObjectField(..)
- , OperationDefinition(..)
- , OperationType(..)
- , Selection(..)
- , SelectionSet
- , SelectionSetOpt
- , Type(..)
- , TypeCondition
- , Value(..)
- , VariableDefinition(..)
+ ( module Language.GraphQL.AST.Document
) where
-import Data.Int (Int32)
-import Data.List.NonEmpty (NonEmpty)
-import Data.Text (Text)
-
--- * Document
-
--- | GraphQL document.
-type Document = NonEmpty Definition
-
--- | Name
-type Name = Text
-
--- | Directive.
-data Directive = Directive Name [Argument] deriving (Eq, Show)
-
--- * Operations
-
--- | Top-level definition of a document, either an operation or a fragment.
-data Definition
- = DefinitionOperation OperationDefinition
- | DefinitionFragment FragmentDefinition
- deriving (Eq, Show)
-
--- | Operation definition.
-data OperationDefinition
- = OperationSelectionSet SelectionSet
- | OperationDefinition OperationType
- (Maybe Name)
- [VariableDefinition]
- [Directive]
- SelectionSet
- deriving (Eq, Show)
-
--- | GraphQL has 3 operation types: queries, mutations and subscribtions.
---
--- Currently only queries and mutations are supported.
-data OperationType = Query | Mutation deriving (Eq, Show)
-
--- * Selections
-
--- | "Top-level" selection, selection on an operation or fragment.
-type SelectionSet = NonEmpty Selection
-
--- | Field selection.
-type SelectionSetOpt = [Selection]
-
--- | Single selection element.
-data Selection
- = SelectionField Field
- | SelectionFragmentSpread FragmentSpread
- | SelectionInlineFragment InlineFragment
- deriving (Eq, Show)
-
--- * Field
-
--- | Single GraphQL field.
---
--- The only required property of a field is its name. Optionally it can also
--- have an alias, arguments or a list of subfields.
---
--- Given the following query:
---
--- @
--- {
--- zuck: user(id: 4) {
--- id
--- name
--- }
--- }
--- @
---
--- * "user", "id" and "name" are field names.
--- * "user" has two subfields, "id" and "name".
--- * "zuck" is an alias for "user". "id" and "name" have no aliases.
--- * "id: 4" is an argument for "user". "id" and "name" don't have any
--- arguments.
-data Field
- = Field (Maybe Alias) Name [Argument] [Directive] SelectionSetOpt
- deriving (Eq, Show)
-
--- | Alternative field name.
---
--- @
--- {
--- smallPic: profilePic(size: 64)
--- bigPic: profilePic(size: 1024)
--- }
--- @
---
--- Here "smallPic" and "bigPic" are aliases for the same field, "profilePic",
--- used to distinquish between profile pictures with different arguments
--- (sizes).
-type Alias = Name
-
--- | Single argument.
---
--- @
--- {
--- user(id: 4) {
--- name
--- }
--- }
--- @
---
--- Here "id" is an argument for the field "user" and its value is 4.
-data Argument = Argument Name Value deriving (Eq,Show)
-
--- * Fragments
-
--- | Fragment spread.
-data FragmentSpread = FragmentSpread Name [Directive] deriving (Eq, Show)
-
--- | Inline fragment.
-data InlineFragment = InlineFragment (Maybe TypeCondition) [Directive] SelectionSet
- deriving (Eq, Show)
-
--- | Fragment definition.
-data FragmentDefinition
- = FragmentDefinition Name TypeCondition [Directive] SelectionSet
- deriving (Eq, Show)
-
--- * Inputs
-
--- | Input value.
-data Value = Variable Name
- | Int Int32
- | Float Double
- | String Text
- | Boolean Bool
- | Null
- | Enum Name
- | List [Value]
- | Object [ObjectField]
- deriving (Eq, Show)
-
--- | Key-value pair.
---
--- A list of 'ObjectField's represents a GraphQL object type.
-data ObjectField = ObjectField Name Value deriving (Eq, Show)
-
--- | Variable definition.
-data VariableDefinition = VariableDefinition Name Type (Maybe Value)
- deriving (Eq, Show)
-
--- | Type condition.
-type TypeCondition = Name
-
--- | Type representation.
-data Type = TypeNamed Name
- | TypeList Type
- | TypeNonNull NonNullType
- deriving (Eq, Show)
-
--- | Helper type to represent Non-Null types and lists of such types.
-data NonNullType = NonNullTypeNamed Name
- | NonNullTypeList Type
- deriving (Eq, Show)
+import Language.GraphQL.AST.Document
diff --git a/src/Language/GraphQL/AST/Core.hs b/src/Language/GraphQL/AST/Core.hs
index 7ba4830..084ae21 100644
--- a/src/Language/GraphQL/AST/Core.hs
+++ b/src/Language/GraphQL/AST/Core.hs
@@ -1,7 +1,6 @@
-- | This is the AST meant to be executed.
module Language.GraphQL.AST.Core
( Alias
- , Argument(..)
, Arguments(..)
, Directive(..)
, Document
@@ -35,16 +34,19 @@ data Operation
-- | Single GraphQL field.
data Field
- = Field (Maybe Alias) Name [Argument] (Seq Selection)
+ = Field (Maybe Alias) Name Arguments (Seq Selection)
deriving (Eq, Show)
--- | Single argument.
-data Argument = Argument Name Value deriving (Eq, Show)
-
-- | Argument list.
newtype Arguments = Arguments (HashMap Name Value)
deriving (Eq, Show)
+instance Semigroup Arguments where
+ (Arguments x) <> (Arguments y) = Arguments $ x <> y
+
+instance Monoid Arguments where
+ mempty = Arguments mempty
+
-- | Directive.
data Directive = Directive Name Arguments
deriving (Eq, Show)
diff --git a/src/Language/GraphQL/AST/DirectiveLocation.hs b/src/Language/GraphQL/AST/DirectiveLocation.hs
new file mode 100644
index 0000000..5b7a36f
--- /dev/null
+++ b/src/Language/GraphQL/AST/DirectiveLocation.hs
@@ -0,0 +1,41 @@
+-- | Various parts of a GraphQL document can be annotated with directives.
+-- This module describes locations in a document where directives can appear.
+module Language.GraphQL.AST.DirectiveLocation
+ ( DirectiveLocation(..)
+ , ExecutableDirectiveLocation(..)
+ , TypeSystemDirectiveLocation(..)
+ ) where
+
+-- | All directives can be splitted in two groups: directives used to annotate
+-- various parts of executable definitions and the ones used in the schema
+-- definition.
+data DirectiveLocation
+ = ExecutableDirectiveLocation ExecutableDirectiveLocation
+ | TypeSystemDirectiveLocation TypeSystemDirectiveLocation
+ deriving (Eq, Show)
+
+-- | Where directives can appear in an executable definition, like a query.
+data ExecutableDirectiveLocation
+ = Query
+ | Mutation
+ | Subscription
+ | Field
+ | FragmentDefinition
+ | FragmentSpread
+ | InlineFragment
+ deriving (Eq, Show)
+
+-- | Where directives can appear in a type system definition.
+data TypeSystemDirectiveLocation
+ = Schema
+ | Scalar
+ | Object
+ | FieldDefinition
+ | ArgumentDefinition
+ | Interface
+ | Union
+ | Enum
+ | EnumValue
+ | InputObject
+ | InputFieldDefinition
+ deriving (Eq, Show)
diff --git a/src/Language/GraphQL/AST/Document.hs b/src/Language/GraphQL/AST/Document.hs
new file mode 100644
index 0000000..3b13691
--- /dev/null
+++ b/src/Language/GraphQL/AST/Document.hs
@@ -0,0 +1,486 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+-- | This module defines an abstract syntax tree for the @GraphQL@ language. It
+-- follows closely the structure given in the specification. Please refer to
+-- <https://facebook.github.io/graphql/ Facebook's GraphQL Specification>.
+-- for more information.
+module Language.GraphQL.AST.Document
+ ( Alias
+ , Argument(..)
+ , ArgumentsDefinition(..)
+ , Definition(..)
+ , Description(..)
+ , Directive(..)
+ , Document
+ , EnumValueDefinition(..)
+ , ExecutableDefinition(..)
+ , FieldDefinition(..)
+ , FragmentDefinition(..)
+ , ImplementsInterfaces(..)
+ , InputValueDefinition(..)
+ , Name
+ , NamedType
+ , NonNullType(..)
+ , ObjectField(..)
+ , OperationDefinition(..)
+ , OperationType(..)
+ , OperationTypeDefinition(..)
+ , SchemaExtension(..)
+ , Selection(..)
+ , SelectionSet
+ , SelectionSetOpt
+ , Type(..)
+ , TypeCondition
+ , TypeDefinition(..)
+ , TypeExtension(..)
+ , TypeSystemDefinition(..)
+ , TypeSystemExtension(..)
+ , UnionMemberTypes(..)
+ , Value(..)
+ , VariableDefinition(..)
+ ) where
+
+import Data.Foldable (toList)
+import Data.Int (Int32)
+import Data.List.NonEmpty (NonEmpty)
+import Data.Text (Text)
+import qualified Data.Text as Text
+import Language.GraphQL.AST.DirectiveLocation
+
+-- * Language
+
+-- ** Source Text
+
+-- | Name.
+type Name = Text
+
+-- ** Document
+
+-- | GraphQL document.
+type Document = NonEmpty Definition
+
+-- | All kinds of definitions that can occur in a GraphQL document.
+data Definition
+ = ExecutableDefinition ExecutableDefinition
+ | TypeSystemDefinition TypeSystemDefinition
+ | TypeSystemExtension TypeSystemExtension
+ deriving (Eq, Show)
+
+-- | Top-level definition of a document, either an operation or a fragment.
+data ExecutableDefinition
+ = DefinitionOperation OperationDefinition
+ | DefinitionFragment FragmentDefinition
+ deriving (Eq, Show)
+
+-- ** Operations
+
+-- | Operation definition.
+data OperationDefinition
+ = SelectionSet SelectionSet
+ | OperationDefinition
+ OperationType
+ (Maybe Name)
+ [VariableDefinition]
+ [Directive]
+ SelectionSet
+ deriving (Eq, Show)
+
+-- | GraphQL has 3 operation types:
+--
+-- * query - a read-only fetch.
+-- * mutation - a write operation followed by a fetch.
+-- * subscription - a long-lived request that fetches data in response to
+-- source events.
+--
+-- Currently only queries and mutations are supported.
+data OperationType = Query | Mutation deriving (Eq, Show)
+
+-- ** Selection Sets
+
+-- | "Top-level" selection, selection on an operation or fragment.
+type SelectionSet = NonEmpty Selection
+
+-- | Field selection.
+type SelectionSetOpt = [Selection]
+
+-- | Selection is a single entry in a selection set. It can be a single field,
+-- fragment spread or inline fragment.
+--
+-- The only required property of a field is its name. Optionally it can also
+-- have an alias, arguments, directives and a list of subfields.
+--
+-- In the following query "user" is a field with two subfields, "id" and "name":
+--
+-- @
+-- {
+-- user {
+-- id
+-- name
+-- }
+-- }
+-- @
+--
+-- A fragment spread refers to a fragment defined outside the operation and is
+-- expanded at the execution time.
+--
+-- @
+-- {
+-- user {
+-- ...userFragment
+-- }
+-- }
+--
+-- fragment userFragment on UserType {
+-- id
+-- name
+-- }
+-- @
+--
+-- Inline fragments are similar but they don't have any name and the type
+-- condition ("on UserType") is optional.
+--
+-- @
+-- {
+-- user {
+-- ... on UserType {
+-- id
+-- name
+-- }
+-- }
+-- @
+data Selection
+ = Field (Maybe Alias) Name [Argument] [Directive] SelectionSetOpt
+ | FragmentSpread Name [Directive]
+ | InlineFragment (Maybe TypeCondition) [Directive] SelectionSet
+ deriving (Eq, Show)
+
+-- ** Arguments
+
+-- | Single argument.
+--
+-- @
+-- {
+-- user(id: 4) {
+-- name
+-- }
+-- }
+-- @
+--
+-- Here "id" is an argument for the field "user" and its value is 4.
+data Argument = Argument Name Value deriving (Eq,Show)
+
+-- ** Field Alias
+
+-- | Alternative field name.
+--
+-- @
+-- {
+-- smallPic: profilePic(size: 64)
+-- bigPic: profilePic(size: 1024)
+-- }
+-- @
+--
+-- Here "smallPic" and "bigPic" are aliases for the same field, "profilePic",
+-- used to distinquish between profile pictures with different arguments
+-- (sizes).
+type Alias = Name
+
+-- ** Fragments
+
+-- | Fragment definition.
+data FragmentDefinition
+ = FragmentDefinition Name TypeCondition [Directive] SelectionSet
+ deriving (Eq, Show)
+
+-- | Type condition.
+type TypeCondition = Name
+
+-- ** Input Values
+
+-- | Input value.
+data Value
+ = Variable Name
+ | Int Int32
+ | Float Double
+ | String Text
+ | Boolean Bool
+ | Null
+ | Enum Name
+ | List [Value]
+ | Object [ObjectField]
+ deriving (Eq, Show)
+
+-- | Key-value pair.
+--
+-- A list of 'ObjectField's represents a GraphQL object type.
+data ObjectField = ObjectField Name Value deriving (Eq, Show)
+
+-- ** Variables
+
+-- | Variable definition.
+data VariableDefinition = VariableDefinition Name Type (Maybe Value)
+ deriving (Eq, Show)
+
+-- ** Type References
+
+-- | Type representation.
+data Type
+ = TypeNamed Name
+ | TypeList Type
+ | TypeNonNull NonNullType
+ deriving (Eq, Show)
+
+-- | Represents type names.
+type NamedType = Name
+
+-- | Helper type to represent Non-Null types and lists of such types.
+data NonNullType
+ = NonNullTypeNamed Name
+ | NonNullTypeList Type
+ deriving (Eq, Show)
+
+-- ** Directives
+
+-- | Directive.
+--
+-- Directives begin with "@", can accept arguments, and can be applied to the
+-- most GraphQL elements, providing additional information.
+data Directive = Directive Name [Argument] deriving (Eq, Show)
+
+-- * Type System
+
+-- | Type system can define a schema, a type or a directive.
+--
+-- @
+-- schema {
+-- query: Query
+-- }
+--
+-- directive @example on FIELD_DEFINITION
+--
+-- type Query {
+-- field: String @example
+-- }
+-- @
+--
+-- This example defines a custom directive "@example", which is applied to a
+-- field definition of the type definition "Query". On the top the schema
+-- is defined by taking advantage of the type "Query".
+data TypeSystemDefinition
+ = SchemaDefinition [Directive] (NonEmpty OperationTypeDefinition)
+ | TypeDefinition TypeDefinition
+ | DirectiveDefinition
+ Description Name ArgumentsDefinition (NonEmpty DirectiveLocation)
+ deriving (Eq, Show)
+
+-- ** Type System Extensions
+
+-- | Extension for a type system definition. Only schema and type definitions
+-- can be extended.
+data TypeSystemExtension
+ = SchemaExtension SchemaExtension
+ | TypeExtension TypeExtension
+ deriving (Eq, Show)
+
+-- ** Schema
+
+-- | Root operation type definition.
+--
+-- Defining root operation types is not required since they have defaults. So
+-- the default query root type is "Query", and the default mutation root type
+-- is "Mutation". But these defaults can be changed for a specific schema. In
+-- the following code the query root type is changed to "MyQueryRootType", and
+-- the mutation root type to "MyMutationRootType":
+--
+-- @
+-- schema {
+-- query: MyQueryRootType
+-- mutation: MyMutationRootType
+-- }
+-- @
+data OperationTypeDefinition
+ = OperationTypeDefinition OperationType NamedType
+ deriving (Eq, Show)
+
+-- | Extension of the schema definition by further operations or directives.
+data SchemaExtension
+ = SchemaOperationExtension [Directive] (NonEmpty OperationTypeDefinition)
+ | SchemaDirectivesExtension (NonEmpty Directive)
+ deriving (Eq, Show)
+
+-- ** Descriptions
+
+-- | GraphQL has built-in capability to document service APIs. Documentation
+-- is a GraphQL string that precedes a particular definition and contains
+-- Markdown. Any GraphQL definition can be documented this way.
+--
+-- @
+-- """
+-- Supported languages.
+-- """
+-- enum Language {
+-- "English"
+-- EN
+--
+-- "Russian"
+-- RU
+-- }
+-- @
+newtype Description = Description (Maybe Text)
+ deriving (Eq, Show)
+
+-- ** Types
+
+-- | Type definitions describe various user-defined types.
+data TypeDefinition
+ = ScalarTypeDefinition Description Name [Directive]
+ | ObjectTypeDefinition
+ Description
+ Name
+ (ImplementsInterfaces [])
+ [Directive]
+ [FieldDefinition]
+ | InterfaceTypeDefinition Description Name [Directive] [FieldDefinition]
+ | UnionTypeDefinition Description Name [Directive] (UnionMemberTypes [])
+ | EnumTypeDefinition Description Name [Directive] [EnumValueDefinition]
+ | InputObjectTypeDefinition
+ Description Name [Directive] [InputValueDefinition]
+ deriving (Eq, Show)
+
+-- | Extensions for custom, already defined types.
+data TypeExtension
+ = ScalarTypeExtension Name (NonEmpty Directive)
+ | ObjectTypeFieldsDefinitionExtension
+ Name (ImplementsInterfaces []) [Directive] (NonEmpty FieldDefinition)
+ | ObjectTypeDirectivesExtension
+ Name (ImplementsInterfaces []) (NonEmpty Directive)
+ | ObjectTypeImplementsInterfacesExtension
+ Name (ImplementsInterfaces NonEmpty)
+ | InterfaceTypeFieldsDefinitionExtension
+ Name [Directive] (NonEmpty FieldDefinition)
+ | InterfaceTypeDirectivesExtension Name (NonEmpty Directive)
+ | UnionTypeUnionMemberTypesExtension
+ Name [Directive] (UnionMemberTypes NonEmpty)
+ | UnionTypeDirectivesExtension Name (NonEmpty Directive)
+ | EnumTypeEnumValuesDefinitionExtension
+ Name [Directive] (NonEmpty EnumValueDefinition)
+ | EnumTypeDirectivesExtension Name (NonEmpty Directive)
+ | InputObjectTypeInputFieldsDefinitionExtension
+ Name [Directive] (NonEmpty InputValueDefinition)
+ | InputObjectTypeDirectivesExtension Name (NonEmpty Directive)
+ deriving (Eq, Show)
+
+-- ** Objects
+
+-- | Defines a list of interfaces implemented by the given object type.
+--
+-- @
+-- type Business implements NamedEntity & ValuedEntity {
+-- name: String
+-- }
+-- @
+--
+-- Here the object type "Business" implements two interfaces: "NamedEntity" and
+-- "ValuedEntity".
+newtype ImplementsInterfaces t = ImplementsInterfaces (t NamedType)
+
+instance Foldable t => Eq (ImplementsInterfaces t) where
+ (ImplementsInterfaces xs) == (ImplementsInterfaces ys)
+ = toList xs == toList ys
+
+instance Foldable t => Show (ImplementsInterfaces t) where
+ show (ImplementsInterfaces interfaces) = Text.unpack
+ $ Text.append "implements"
+ $ Text.intercalate " & "
+ $ toList interfaces
+
+-- | Definition of a single field in a type.
+--
+-- @
+-- type Person {
+-- name: String
+-- picture(width: Int, height: Int): Url
+-- }
+-- @
+--
+-- "name" and "picture", including their arguments and types, are field
+-- definitions.
+data FieldDefinition
+ = FieldDefinition Description Name ArgumentsDefinition Type [Directive]
+ deriving (Eq, Show)
+
+-- | A list of values passed to a field.
+--
+-- @
+-- type Person {
+-- name: String
+-- picture(width: Int, height: Int): Url
+-- }
+-- @
+--
+-- "Person" has two fields, "name" and "picture". "name" doesn't have any
+-- arguments, so 'ArgumentsDefinition' contains an empty list. "picture"
+-- contains definitions for 2 arguments: "width" and "height".
+newtype ArgumentsDefinition = ArgumentsDefinition [InputValueDefinition]
+ deriving (Eq, Show)
+
+instance Semigroup ArgumentsDefinition where
+ (ArgumentsDefinition xs) <> (ArgumentsDefinition ys) =
+ ArgumentsDefinition $ xs <> ys
+
+instance Monoid ArgumentsDefinition where
+ mempty = ArgumentsDefinition []
+
+-- | Defines an input value.
+--
+-- * Input values can define field arguments, see 'ArgumentsDefinition'.
+-- * They can also be used as field definitions in an input type.
+--
+-- @
+-- input Point2D {
+-- x: Float
+-- y: Float
+-- }
+-- @
+--
+-- The input type "Point2D" contains two value definitions: "x" and "y".
+data InputValueDefinition
+ = InputValueDefinition Description Name Type (Maybe Value) [Directive]
+ deriving (Eq, Show)
+
+-- ** Unions
+
+-- | List of types forming a union.
+--
+-- @
+-- union SearchResult = Person | Photo
+-- @
+--
+-- "Person" and "Photo" are member types of the union "SearchResult".
+newtype UnionMemberTypes t = UnionMemberTypes (t NamedType)
+
+instance Foldable t => Eq (UnionMemberTypes t) where
+ (UnionMemberTypes xs) == (UnionMemberTypes ys) = toList xs == toList ys
+
+instance Foldable t => Show (UnionMemberTypes t) where
+ show (UnionMemberTypes memberTypes) = Text.unpack
+ $ Text.intercalate " | "
+ $ toList memberTypes
+
+-- ** Enums
+
+-- | Single value in an enum definition.
+--
+-- @
+-- enum Direction {
+-- NORTH
+-- EAST
+-- SOUTH
+-- WEST
+-- }
+-- @
+--
+-- "NORTH, "EAST", "SOUTH", and "WEST" are value definitions of an enum type
+-- definition "Direction".
+data EnumValueDefinition = EnumValueDefinition Description Name [Directive]
+ deriving (Eq, Show)
diff --git a/src/Language/GraphQL/AST/Encoder.hs b/src/Language/GraphQL/AST/Encoder.hs
index 508212a..69f5599 100644
--- a/src/Language/GraphQL/AST/Encoder.hs
+++ b/src/Language/GraphQL/AST/Encoder.hs
@@ -15,7 +15,6 @@ module Language.GraphQL.AST.Encoder
import Data.Char (ord)
import Data.Foldable (fold)
-import Data.Monoid ((<>))
import qualified Data.List.NonEmpty as NonEmpty
import Data.Text (Text)
import qualified Data.Text as Text
@@ -26,6 +25,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,16 +43,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 = NonEmpty.toList $ definition formatter <$> defs
+ encodeDocument = foldr executableDefinition [] defs
+ executableDefinition (ExecutableDefinition x) acc = definition formatter x : acc
+ executableDefinition _ acc = acc
--- | Converts a 'Full.Definition' into a string.
-definition :: Formatter -> Full.Definition -> Lazy.Text
+-- | Converts a t'Full.ExecutableDefinition' into a string.
+definition :: Formatter -> ExecutableDefinition -> Lazy.Text
definition formatter x
| Pretty _ <- formatter = Lazy.Text.snoc (encodeDefinition x) '\n'
| Minified <- formatter = encodeDefinition x
@@ -62,14 +64,16 @@ definition formatter x
encodeDefinition (Full.DefinitionFragment fragment)
= fragmentDefinition formatter fragment
+-- | Converts a 'Full.OperationDefinition into a string.
operationDefinition :: Formatter -> Full.OperationDefinition -> Lazy.Text
-operationDefinition formatter (Full.OperationSelectionSet sels)
+operationDefinition formatter (Full.SelectionSet sels)
= selectionSet formatter sels
operationDefinition formatter (Full.OperationDefinition Full.Query name vars dirs sels)
= "query " <> node formatter name vars dirs sels
operationDefinition formatter (Full.OperationDefinition Full.Mutation name vars dirs sels)
= "mutation " <> node formatter name vars dirs sels
+-- | Converts a Full.Query or Full.Mutation into a string.
node :: Formatter ->
Maybe Full.Name ->
[Full.VariableDefinition] ->
@@ -110,17 +114,21 @@ selectionSet formatter
selectionSetOpt :: Formatter -> Full.SelectionSetOpt -> Lazy.Text
selectionSetOpt formatter = bracesList formatter $ selection formatter
+indentSymbol :: Lazy.Text
+indentSymbol = " "
+
indent :: (Integral a) => a -> Lazy.Text
-indent indentation = Lazy.Text.replicate (fromIntegral indentation) " "
+indent indentation = Lazy.Text.replicate (fromIntegral indentation) indentSymbol
selection :: Formatter -> Full.Selection -> Lazy.Text
selection formatter = Lazy.Text.append indent' . encodeSelection
where
- encodeSelection (Full.SelectionField field') = field incrementIndent field'
- encodeSelection (Full.SelectionInlineFragment fragment) =
- inlineFragment incrementIndent fragment
- encodeSelection (Full.SelectionFragmentSpread spread) =
- fragmentSpread incrementIndent spread
+ encodeSelection (Full.Field alias name args directives' selections) =
+ field incrementIndent alias name args directives' selections
+ encodeSelection (Full.InlineFragment typeCondition directives' selections) =
+ inlineFragment incrementIndent typeCondition directives' selections
+ encodeSelection (Full.FragmentSpread name directives') =
+ fragmentSpread incrementIndent name directives'
incrementIndent
| Pretty indentation <- formatter = Pretty $ indentation + 1
| otherwise = Minified
@@ -131,8 +139,15 @@ selection formatter = Lazy.Text.append indent' . encodeSelection
colon :: Formatter -> Lazy.Text
colon formatter = eitherFormat formatter ": " ":"
-field :: Formatter -> Full.Field -> Lazy.Text
-field formatter (Full.Field alias name args dirs set)
+-- | Converts Full.Field into a string
+field :: Formatter ->
+ Maybe Full.Name ->
+ Full.Name ->
+ [Full.Argument] ->
+ [Full.Directive] ->
+ [Full.Selection] ->
+ Lazy.Text
+field formatter alias name args dirs set
= optempty prependAlias (fold alias)
<> Lazy.Text.fromStrict name
<> optempty (arguments formatter) args
@@ -154,13 +169,18 @@ argument formatter (Full.Argument name value')
-- * Fragments
-fragmentSpread :: Formatter -> Full.FragmentSpread -> Lazy.Text
-fragmentSpread formatter (Full.FragmentSpread name ds)
- = "..." <> Lazy.Text.fromStrict name <> optempty (directives formatter) ds
+fragmentSpread :: Formatter -> Full.Name -> [Full.Directive] -> Lazy.Text
+fragmentSpread formatter name directives'
+ = "..." <> Lazy.Text.fromStrict name
+ <> optempty (directives formatter) directives'
-inlineFragment :: Formatter -> Full.InlineFragment -> Lazy.Text
-inlineFragment formatter (Full.InlineFragment tc dirs sels)
- = "... on "
+inlineFragment ::
+ Formatter ->
+ Maybe Full.TypeCondition ->
+ [Full.Directive] ->
+ Full.SelectionSet ->
+ Lazy.Text
+inlineFragment formatter tc dirs sels = "... on "
<> Lazy.Text.fromStrict (fold tc)
<> directives formatter dirs
<> eitherFormat formatter " " mempty
@@ -191,7 +211,7 @@ value _ (Full.Variable x) = variable x
value _ (Full.Int x) = Builder.toLazyText $ decimal x
value _ (Full.Float x) = Builder.toLazyText $ realFloat x
value _ (Full.Boolean x) = booleanValue x
-value _ Full.Null = mempty
+value _ Full.Null = "null"
value formatter (Full.String string) = stringValue formatter string
value _ (Full.Enum x) = Lazy.Text.fromStrict x
value formatter (Full.List x) = listValue formatter x
@@ -201,26 +221,40 @@ booleanValue :: Bool -> Lazy.Text
booleanValue True = "true"
booleanValue False = "false"
+quote :: Builder.Builder
+quote = Builder.singleton '\"'
+
+oneLine :: Text -> Builder
+oneLine string = quote <> Text.foldr (mappend . escape) quote string
+
stringValue :: Formatter -> Text -> Lazy.Text
stringValue Minified string = Builder.toLazyText
- $ quote <> Text.foldr (mappend . escape') quote string
- where
- quote = Builder.singleton '\"'
- escape' '\n' = Builder.fromString "\\n"
- escape' char = escape char
-stringValue (Pretty indentation) string = byStringType $ Text.lines string
- where
- byStringType [] = "\"\""
- byStringType [line] = Builder.toLazyText
- $ quote <> Text.foldr (mappend . escape) quote line
- byStringType lines' = "\"\"\"\n"
- <> Lazy.Text.unlines (transformLine <$> lines')
- <> indent indentation
- <> "\"\"\""
- transformLine = (indent (indentation + 1) <>)
- . Lazy.Text.fromStrict
- . Text.replace "\"\"\"" "\\\"\"\""
- quote = Builder.singleton '\"'
+ $ quote <> Text.foldr (mappend . escape) quote string
+stringValue (Pretty indentation) string =
+ if hasEscaped string
+ then stringValue Minified string
+ else Builder.toLazyText $ encoded lines'
+ where
+ isWhiteSpace char = char == ' ' || char == '\t'
+ isNewline char = char == '\n' || char == '\r'
+ hasEscaped = Text.any (not . isAllowed)
+ isAllowed char =
+ char == '\t' || isNewline char || (char >= '\x0020' && char /= '\x007F')
+
+ tripleQuote = Builder.fromText "\"\"\""
+ start = tripleQuote <> Builder.singleton '\n'
+ end = Builder.fromLazyText (indent indentation) <> tripleQuote
+
+ strip = Text.dropWhile isWhiteSpace . Text.dropWhileEnd isWhiteSpace
+ lines' = map Builder.fromText $ Text.split isNewline (Text.replace "\r\n" "\n" $ strip string)
+ encoded [] = oneLine string
+ encoded [_] = oneLine string
+ encoded lines'' = start <> transformLines lines'' <> end
+ transformLines = foldr ((\line acc -> line <> Builder.singleton '\n' <> acc) . transformLine) mempty
+ transformLine line =
+ if Lazy.Text.null (Builder.toLazyText line)
+ then line
+ else Builder.fromLazyText (indent (indentation + 1)) <> line
escape :: Char -> Builder
escape char'
@@ -228,7 +262,9 @@ escape char'
| char' == '\"' = Builder.fromString "\\\""
| char' == '\b' = Builder.fromString "\\b"
| char' == '\f' = Builder.fromString "\\f"
+ | char' == '\n' = Builder.fromString "\\n"
| char' == '\r' = Builder.fromString "\\r"
+ | char' == '\t' = Builder.fromString "\\t"
| char' < '\x0010' = unicode "\\u000" char'
| char' < '\x0020' = unicode "\\u00" char'
| otherwise = Builder.singleton char'
diff --git a/src/Language/GraphQL/AST/Lexer.hs b/src/Language/GraphQL/AST/Lexer.hs
index f95070c..0ba55e3 100644
--- a/src/Language/GraphQL/AST/Lexer.hs
+++ b/src/Language/GraphQL/AST/Lexer.hs
@@ -15,6 +15,7 @@ module Language.GraphQL.AST.Lexer
, dollar
, comment
, equals
+ , extend
, integer
, float
, lexeme
@@ -28,20 +29,16 @@ module Language.GraphQL.AST.Lexer
, unicodeBOM
) where
-import Control.Applicative ( Alternative(..)
- , liftA2
- )
-import Data.Char ( chr
- , digitToInt
- , isAsciiLower
- , isAsciiUpper
- , ord
- )
+import Control.Applicative (Alternative(..), liftA2)
+import Data.Char (chr, digitToInt, isAsciiLower, isAsciiUpper, ord)
import Data.Foldable (foldl')
import Data.List (dropWhileEnd)
+import qualified Data.List.NonEmpty as NonEmpty
+import Data.List.NonEmpty (NonEmpty(..))
import Data.Proxy (Proxy(..))
import Data.Void (Void)
import Text.Megaparsec ( Parsec
+ , (<?>)
, between
, chunk
, chunkToTokens
@@ -56,11 +53,9 @@ import Text.Megaparsec ( Parsec
, takeWhile1P
, try
)
-import Text.Megaparsec.Char ( char
- , digitChar
- , space1
- )
+import Text.Megaparsec.Char (char, digitChar, space1)
import qualified Text.Megaparsec.Char.Lexer as Lexer
+import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
@@ -97,8 +92,8 @@ dollar :: Parser T.Text
dollar = symbol "$"
-- | Parser for "@".
-at :: Parser Char
-at = char '@'
+at :: Parser Text
+at = symbol "@"
-- | Parser for "&".
amp :: Parser T.Text
@@ -134,7 +129,7 @@ braces = between (symbol "{") (symbol "}")
-- | Parser for strings.
string :: Parser T.Text
-string = between "\"" "\"" stringValue <* spaceConsumer
+string = between "\"" "\"" stringValue <* spaceConsumer
where
stringValue = T.pack <$> many stringCharacter
stringCharacter = satisfy isStringCharacter1
@@ -143,7 +138,7 @@ string = between "\"" "\"" stringValue <* spaceConsumer
-- | Parser for block strings.
blockString :: Parser T.Text
-blockString = between "\"\"\"" "\"\"\"" stringValue <* spaceConsumer
+blockString = between "\"\"\"" "\"\"\"" stringValue <* spaceConsumer
where
stringValue = do
byLine <- sepBy (many blockStringCharacter) lineTerminator
@@ -226,3 +221,16 @@ escapeSequence = do
-- | Parser for the "Byte Order Mark".
unicodeBOM :: Parser ()
unicodeBOM = optional (char '\xfeff') >> pure ()
+
+-- | Parses "extend" followed by a 'symbol'. It is used by schema extensions.
+extend :: forall a. Text -> String -> NonEmpty (Parser a) -> Parser a
+extend token extensionLabel parsers
+ = foldr combine headParser (NonEmpty.tail parsers)
+ <?> extensionLabel
+ where
+ headParser = tryExtension $ NonEmpty.head parsers
+ combine current accumulated = accumulated <|> tryExtension current
+ tryExtension extensionParser = try
+ $ symbol "extend"
+ *> symbol token
+ *> extensionParser \ No newline at end of file
diff --git a/src/Language/GraphQL/AST/Parser.hs b/src/Language/GraphQL/AST/Parser.hs
index 1505615..3449903 100644
--- a/src/Language/GraphQL/AST/Parser.hs
+++ b/src/Language/GraphQL/AST/Parser.hs
@@ -6,63 +6,358 @@ module Language.GraphQL.AST.Parser
( document
) where
-import Control.Applicative ( Alternative(..)
- , optional
- )
+import Control.Applicative (Alternative(..), optional)
+import Control.Applicative.Combinators (sepBy1)
+import qualified Control.Applicative.Combinators.NonEmpty as NonEmpty
import Data.List.NonEmpty (NonEmpty(..))
-import Language.GraphQL.AST
+import Data.Text (Text)
+import qualified Language.GraphQL.AST.DirectiveLocation as Directive
+import Language.GraphQL.AST.DirectiveLocation
+ ( DirectiveLocation
+ , ExecutableDirectiveLocation
+ , TypeSystemDirectiveLocation
+ )
+import Language.GraphQL.AST.Document
import Language.GraphQL.AST.Lexer
-import Text.Megaparsec ( lookAhead
- , option
- , try
- , (<?>)
- )
+import Text.Megaparsec (lookAhead, option, try, (<?>))
-- | Parser for the GraphQL documents.
document :: Parser Document
-document = unicodeBOM >> spaceConsumer >> lexeme (manyNE definition)
+document = unicodeBOM
+ >> spaceConsumer
+ >> lexeme (NonEmpty.some definition)
definition :: Parser Definition
-definition = DefinitionOperation <$> operationDefinition
- <|> DefinitionFragment <$> fragmentDefinition
- <?> "definition error!"
+definition = ExecutableDefinition <$> executableDefinition
+ <|> TypeSystemDefinition <$> typeSystemDefinition
+ <|> TypeSystemExtension <$> typeSystemExtension
+ <?> "Definition"
+
+executableDefinition :: Parser ExecutableDefinition
+executableDefinition = DefinitionOperation <$> operationDefinition
+ <|> DefinitionFragment <$> fragmentDefinition
+ <?> "ExecutableDefinition"
+
+typeSystemDefinition :: Parser TypeSystemDefinition
+typeSystemDefinition = schemaDefinition
+ <|> TypeDefinition <$> typeDefinition
+ <|> directiveDefinition
+ <?> "TypeSystemDefinition"
+
+typeSystemExtension :: Parser TypeSystemExtension
+typeSystemExtension = SchemaExtension <$> schemaExtension
+ <|> TypeExtension <$> typeExtension
+ <?> "TypeSystemExtension"
+
+directiveDefinition :: Parser TypeSystemDefinition
+directiveDefinition = DirectiveDefinition
+ <$> description
+ <* symbol "directive"
+ <* at
+ <*> name
+ <*> argumentsDefinition
+ <* symbol "on"
+ <*> directiveLocations
+ <?> "DirectiveDefinition"
+
+directiveLocations :: Parser (NonEmpty DirectiveLocation)
+directiveLocations = optional pipe
+ *> directiveLocation `NonEmpty.sepBy1` pipe
+
+directiveLocation :: Parser DirectiveLocation
+directiveLocation
+ = Directive.ExecutableDirectiveLocation <$> executableDirectiveLocation
+ <|> Directive.TypeSystemDirectiveLocation <$> typeSystemDirectiveLocation
+
+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"
+
+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"
+
+typeDefinition :: Parser TypeDefinition
+typeDefinition = scalarTypeDefinition
+ <|> objectTypeDefinition
+ <|> interfaceTypeDefinition
+ <|> unionTypeDefinition
+ <|> enumTypeDefinition
+ <|> inputObjectTypeDefinition
+ <?> "TypeDefinition"
+
+typeExtension :: Parser TypeExtension
+typeExtension = scalarTypeExtension
+ <|> objectTypeExtension
+ <|> interfaceTypeExtension
+ <|> unionTypeExtension
+ <|> enumTypeExtension
+ <|> inputObjectTypeExtension
+ <?> "TypeExtension"
+
+scalarTypeDefinition :: Parser TypeDefinition
+scalarTypeDefinition = ScalarTypeDefinition
+ <$> description
+ <* symbol "scalar"
+ <*> name
+ <*> directives
+ <?> "ScalarTypeDefinition"
+
+scalarTypeExtension :: Parser TypeExtension
+scalarTypeExtension = extend "scalar" "ScalarTypeExtension"
+ $ (ScalarTypeExtension <$> name <*> NonEmpty.some directive) :| []
+
+objectTypeDefinition :: Parser TypeDefinition
+objectTypeDefinition = ObjectTypeDefinition
+ <$> description
+ <* symbol "type"
+ <*> name
+ <*> option (ImplementsInterfaces []) (implementsInterfaces sepBy1)
+ <*> directives
+ <*> braces (many fieldDefinition)
+ <?> "ObjectTypeDefinition"
+
+objectTypeExtension :: Parser TypeExtension
+objectTypeExtension = extend "type" "ObjectTypeExtension"
+ $ fieldsDefinitionExtension :|
+ [ directivesExtension
+ , implementsInterfacesExtension
+ ]
+ where
+ fieldsDefinitionExtension = ObjectTypeFieldsDefinitionExtension
+ <$> name
+ <*> option (ImplementsInterfaces []) (implementsInterfaces sepBy1)
+ <*> directives
+ <*> braces (NonEmpty.some fieldDefinition)
+ directivesExtension = ObjectTypeDirectivesExtension
+ <$> name
+ <*> option (ImplementsInterfaces []) (implementsInterfaces sepBy1)
+ <*> NonEmpty.some directive
+ implementsInterfacesExtension = ObjectTypeImplementsInterfacesExtension
+ <$> name
+ <*> implementsInterfaces NonEmpty.sepBy1
+
+description :: Parser Description
+description = Description
+ <$> optional (string <|> blockString)
+ <?> "Description"
+
+unionTypeDefinition :: Parser TypeDefinition
+unionTypeDefinition = UnionTypeDefinition
+ <$> description
+ <* symbol "union"
+ <*> name
+ <*> directives
+ <*> option (UnionMemberTypes []) (unionMemberTypes sepBy1)
+ <?> "UnionTypeDefinition"
+
+unionTypeExtension :: Parser TypeExtension
+unionTypeExtension = extend "union" "UnionTypeExtension"
+ $ unionMemberTypesExtension :| [directivesExtension]
+ where
+ unionMemberTypesExtension = UnionTypeUnionMemberTypesExtension
+ <$> name
+ <*> directives
+ <*> unionMemberTypes NonEmpty.sepBy1
+ directivesExtension = UnionTypeDirectivesExtension
+ <$> name
+ <*> NonEmpty.some directive
+
+unionMemberTypes ::
+ Foldable t =>
+ (Parser Text -> Parser Text -> Parser (t NamedType)) ->
+ Parser (UnionMemberTypes t)
+unionMemberTypes sepBy' = UnionMemberTypes
+ <$ equals
+ <* optional pipe
+ <*> name `sepBy'` pipe
+ <?> "UnionMemberTypes"
+
+interfaceTypeDefinition :: Parser TypeDefinition
+interfaceTypeDefinition = InterfaceTypeDefinition
+ <$> description
+ <* symbol "interface"
+ <*> name
+ <*> directives
+ <*> braces (many fieldDefinition)
+ <?> "InterfaceTypeDefinition"
+
+interfaceTypeExtension :: Parser TypeExtension
+interfaceTypeExtension = extend "interface" "InterfaceTypeExtension"
+ $ fieldsDefinitionExtension :| [directivesExtension]
+ where
+ fieldsDefinitionExtension = InterfaceTypeFieldsDefinitionExtension
+ <$> name
+ <*> directives
+ <*> braces (NonEmpty.some fieldDefinition)
+ directivesExtension = InterfaceTypeDirectivesExtension
+ <$> name
+ <*> NonEmpty.some directive
+
+enumTypeDefinition :: Parser TypeDefinition
+enumTypeDefinition = EnumTypeDefinition
+ <$> description
+ <* symbol "enum"
+ <*> name
+ <*> directives
+ <*> listOptIn braces enumValueDefinition
+ <?> "EnumTypeDefinition"
+
+enumTypeExtension :: Parser TypeExtension
+enumTypeExtension = extend "enum" "EnumTypeExtension"
+ $ enumValuesDefinitionExtension :| [directivesExtension]
+ where
+ enumValuesDefinitionExtension = EnumTypeEnumValuesDefinitionExtension
+ <$> name
+ <*> directives
+ <*> braces (NonEmpty.some enumValueDefinition)
+ directivesExtension = EnumTypeDirectivesExtension
+ <$> name
+ <*> NonEmpty.some directive
+
+inputObjectTypeDefinition :: Parser TypeDefinition
+inputObjectTypeDefinition = InputObjectTypeDefinition
+ <$> description
+ <* symbol "input"
+ <*> name
+ <*> directives
+ <*> listOptIn braces inputValueDefinition
+ <?> "InputObjectTypeDefinition"
+
+inputObjectTypeExtension :: Parser TypeExtension
+inputObjectTypeExtension = extend "input" "InputObjectTypeExtension"
+ $ inputFieldsDefinitionExtension :| [directivesExtension]
+ where
+ inputFieldsDefinitionExtension = InputObjectTypeInputFieldsDefinitionExtension
+ <$> name
+ <*> directives
+ <*> braces (NonEmpty.some inputValueDefinition)
+ directivesExtension = InputObjectTypeDirectivesExtension
+ <$> name
+ <*> NonEmpty.some directive
+
+enumValueDefinition :: Parser EnumValueDefinition
+enumValueDefinition = EnumValueDefinition
+ <$> description
+ <*> enumValue
+ <*> directives
+ <?> "EnumValueDefinition"
+
+implementsInterfaces ::
+ Foldable t =>
+ (Parser Text -> Parser Text -> Parser (t NamedType)) ->
+ Parser (ImplementsInterfaces t)
+implementsInterfaces sepBy' = ImplementsInterfaces
+ <$ symbol "implements"
+ <* optional amp
+ <*> name `sepBy'` amp
+ <?> "ImplementsInterfaces"
+
+inputValueDefinition :: Parser InputValueDefinition
+inputValueDefinition = InputValueDefinition
+ <$> description
+ <*> name
+ <* colon
+ <*> type'
+ <*> defaultValue
+ <*> directives
+ <?> "InputValueDefinition"
+
+argumentsDefinition :: Parser ArgumentsDefinition
+argumentsDefinition = ArgumentsDefinition
+ <$> listOptIn parens inputValueDefinition
+ <?> "ArgumentsDefinition"
+
+fieldDefinition :: Parser FieldDefinition
+fieldDefinition = FieldDefinition
+ <$> description
+ <*> name
+ <*> argumentsDefinition
+ <* colon
+ <*> type'
+ <*> directives
+ <?> "FieldDefinition"
+
+schemaDefinition :: Parser TypeSystemDefinition
+schemaDefinition = SchemaDefinition
+ <$ symbol "schema"
+ <*> directives
+ <*> operationTypeDefinitions
+ <?> "SchemaDefinition"
+
+operationTypeDefinitions :: Parser (NonEmpty OperationTypeDefinition)
+operationTypeDefinitions = braces $ NonEmpty.some operationTypeDefinition
+
+schemaExtension :: Parser SchemaExtension
+schemaExtension = extend "schema" "SchemaExtension"
+ $ schemaOperationExtension :| [directivesExtension]
+ where
+ directivesExtension = SchemaDirectivesExtension
+ <$> NonEmpty.some directive
+ schemaOperationExtension = SchemaOperationExtension
+ <$> directives
+ <*> operationTypeDefinitions
+
+operationTypeDefinition :: Parser OperationTypeDefinition
+operationTypeDefinition = OperationTypeDefinition
+ <$> operationType <* colon
+ <*> name
+ <?> "OperationTypeDefinition"
operationDefinition :: Parser OperationDefinition
-operationDefinition = OperationSelectionSet <$> selectionSet
- <|> OperationDefinition <$> operationType
- <*> optional name
- <*> opt variableDefinitions
- <*> opt directives
- <*> selectionSet
- <?> "operationDefinition error"
+operationDefinition = SelectionSet <$> selectionSet
+ <|> operationDefinition'
+ <?> "operationDefinition error"
+ where
+ operationDefinition'
+ = OperationDefinition <$> operationType
+ <*> optional name
+ <*> variableDefinitions
+ <*> directives
+ <*> selectionSet
operationType :: Parser OperationType
operationType = Query <$ symbol "query"
<|> Mutation <$ symbol "mutation"
- <?> "operationType error"
+ -- <?> Keep default error message
-- * SelectionSet
selectionSet :: Parser SelectionSet
-selectionSet = braces $ manyNE selection
+selectionSet = braces $ NonEmpty.some selection
selectionSetOpt :: Parser SelectionSetOpt
-selectionSetOpt = braces $ some selection
+selectionSetOpt = listOptIn braces selection
selection :: Parser Selection
-selection = SelectionField <$> field
- <|> try (SelectionFragmentSpread <$> fragmentSpread)
- <|> SelectionInlineFragment <$> inlineFragment
- <?> "selection error!"
+selection = field
+ <|> try fragmentSpread
+ <|> inlineFragment
+ <?> "selection error!"
-- * Field
-field :: Parser Field
-field = Field <$> optional alias
- <*> name
- <*> opt arguments
- <*> opt directives
- <*> opt selectionSetOpt
+field :: Parser Selection
+field = Field
+ <$> optional alias
+ <*> name
+ <*> arguments
+ <*> directives
+ <*> selectionSetOpt
alias :: Parser Alias
alias = try $ name <* colon
@@ -70,30 +365,32 @@ alias = try $ name <* colon
-- * Arguments
arguments :: Parser [Argument]
-arguments = parens $ some argument
+arguments = listOptIn parens argument
argument :: Parser Argument
argument = Argument <$> name <* colon <*> value
-- * Fragments
-fragmentSpread :: Parser FragmentSpread
-fragmentSpread = FragmentSpread <$ spread
- <*> fragmentName
- <*> opt directives
+fragmentSpread :: Parser Selection
+fragmentSpread = FragmentSpread
+ <$ spread
+ <*> fragmentName
+ <*> directives
-inlineFragment :: Parser InlineFragment
-inlineFragment = InlineFragment <$ spread
- <*> optional typeCondition
- <*> opt directives
- <*> selectionSet
+inlineFragment :: Parser Selection
+inlineFragment = InlineFragment
+ <$ spread
+ <*> optional typeCondition
+ <*> directives
+ <*> selectionSet
fragmentDefinition :: Parser FragmentDefinition
fragmentDefinition = FragmentDefinition
<$ symbol "fragment"
<*> name
<*> typeCondition
- <*> opt directives
+ <*> directives
<*> selectionSet
fragmentName :: Parser Name
@@ -121,68 +418,68 @@ value = Variable <$> variable
booleanValue = True <$ symbol "true"
<|> False <$ symbol "false"
- enumValue :: Parser Name
- enumValue = but (symbol "true") *> but (symbol "false") *> but (symbol "null") *> name
-
listValue :: Parser [Value]
listValue = brackets $ some value
objectValue :: Parser [ObjectField]
objectValue = braces $ some objectField
+enumValue :: Parser Name
+enumValue = but (symbol "true") *> but (symbol "false") *> but (symbol "null") *> name
+
objectField :: Parser ObjectField
-objectField = ObjectField <$> name <* symbol ":" <*> value
+objectField = ObjectField <$> name <* colon <*> value
-- * Variables
variableDefinitions :: Parser [VariableDefinition]
-variableDefinitions = parens $ some variableDefinition
+variableDefinitions = listOptIn parens variableDefinition
variableDefinition :: Parser VariableDefinition
-variableDefinition = VariableDefinition <$> variable
- <* colon
- <*> type_
- <*> optional defaultValue
+variableDefinition = VariableDefinition
+ <$> variable
+ <* colon
+ <*> type'
+ <*> defaultValue
+ <?> "VariableDefinition"
+
variable :: Parser Name
variable = dollar *> name
-defaultValue :: Parser Value
-defaultValue = equals *> value
+defaultValue :: Parser (Maybe Value)
+defaultValue = optional (equals *> value) <?> "DefaultValue"
-- * Input Types
-type_ :: Parser Type
-type_ = try (TypeNonNull <$> nonNullType)
- <|> TypeList <$> brackets type_
+type' :: Parser Type
+type' = try (TypeNonNull <$> nonNullType)
+ <|> TypeList <$> brackets type'
<|> TypeNamed <$> name
- <?> "type_ error!"
+ <?> "Type"
nonNullType :: Parser NonNullType
nonNullType = NonNullTypeNamed <$> name <* bang
- <|> NonNullTypeList <$> brackets type_ <* bang
+ <|> NonNullTypeList <$> brackets type' <* bang
<?> "nonNullType error!"
-- * Directives
directives :: Parser [Directive]
-directives = some directive
+directives = many directive
directive :: Parser Directive
directive = Directive
- <$ at
- <*> name
- <*> opt arguments
+ <$ at
+ <*> name
+ <*> arguments
-- * Internal
-opt :: Monoid a => Parser a -> Parser a
-opt = option mempty
+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 ()
-
-manyNE :: Alternative f => f a -> f (NonEmpty a)
-manyNE p = (:|) <$> p <*> many p
diff --git a/src/Language/GraphQL/Error.hs b/src/Language/GraphQL/Error.hs
index 41a2a9c..91911b7 100644
--- a/src/Language/GraphQL/Error.hs
+++ b/src/Language/GraphQL/Error.hs
@@ -20,18 +20,20 @@ import Control.Monad.Trans.State ( StateT
, modify
, runStateT
)
-import Text.Megaparsec ( ParseErrorBundle(..)
- , SourcePos(..)
- , errorOffset
- , parseErrorTextPretty
- , reachOffset
- , unPos
- )
+import Text.Megaparsec
+ ( ParseErrorBundle(..)
+ , PosState(..)
+ , SourcePos(..)
+ , errorOffset
+ , parseErrorTextPretty
+ , reachOffset
+ , unPos
+ )
-- | Wraps a parse error into a list of errors.
parseError :: Applicative f => ParseErrorBundle Text Void -> f Aeson.Value
parseError ParseErrorBundle{..} =
- pure $ Aeson.object [("errors", Aeson.toJSON $ fst $ foldl go ([], bundlePosState) bundleErrors)]
+ pure $ Aeson.object [("errors", Aeson.toJSON $ fst $ foldl go ([], bundlePosState) bundleErrors)]
where
errorObject s SourcePos{..} = Aeson.object
[ ("message", Aeson.toJSON $ init $ parseErrorTextPretty s)
@@ -39,7 +41,8 @@ parseError ParseErrorBundle{..} =
, ("column", Aeson.toJSON $ unPos sourceColumn)
]
go (result, state) x =
- let (sourcePosition, _, newState) = reachOffset (errorOffset x) state
+ let (_, newState) = reachOffset (errorOffset x) state
+ sourcePosition = pstateSourcePos newState
in (errorObject x sourcePosition : result, newState)
-- | A wrapper to pass error messages around.
diff --git a/src/Language/GraphQL/Execute.hs b/src/Language/GraphQL/Execute.hs
index 74f33f9..204d08c 100644
--- a/src/Language/GraphQL/Execute.hs
+++ b/src/Language/GraphQL/Execute.hs
@@ -6,14 +6,14 @@ module Language.GraphQL.Execute
, executeWithName
) where
-import Control.Monad.IO.Class (MonadIO)
import qualified Data.Aeson as Aeson
-import Data.Foldable (toList)
import Data.List.NonEmpty (NonEmpty(..))
-import qualified Data.List.NonEmpty as NE
+import qualified Data.List.NonEmpty as NonEmpty
+import Data.HashMap.Strict (HashMap)
+import qualified Data.HashMap.Strict as HashMap
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
@@ -24,13 +24,14 @@ import qualified Language.GraphQL.Schema as Schema
--
-- Returns the result of the query against the schema wrapped in a /data/
-- field, or errors wrapped in an /errors/ field.
-execute :: MonadIO m
- => NonEmpty (Schema.Resolver m) -- ^ Resolvers.
+execute :: Monad m
+ => HashMap Text (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
+ maybe transformError (document schema Nothing)
+ $ Transform.document subs doc
where
transformError = return $ singleError "Schema transformation error."
@@ -40,24 +41,25 @@ execute schema subs doc =
--
-- Returns the result of the query against the schema wrapped in a /data/
-- field, or errors wrapped in an /errors/ field.
-executeWithName :: MonadIO m
- => NonEmpty (Schema.Resolver m) -- ^ Resolvers
+executeWithName :: Monad m
+ => HashMap Text (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
+ maybe transformError (document schema $ Just name)
+ $ Transform.document subs doc
where
transformError = return $ singleError "Schema transformation error."
-document :: MonadIO m
- => NonEmpty (Schema.Resolver m)
+document :: Monad m
+ => HashMap Text (NonEmpty (Schema.Resolver m))
-> Maybe Text
-> AST.Core.Document
-> m Aeson.Value
document schema Nothing (op :| []) = operation schema op
-document schema (Just name) operations = case NE.dropWhile matchingName operations of
+document schema (Just name) operations = case NonEmpty.dropWhile matchingName operations of
[] -> return $ singleError
$ Text.unwords ["Operation", name, "couldn't be found in the document."]
(op:_) -> operation schema op
@@ -67,11 +69,18 @@ document schema (Just name) operations = case NE.dropWhile matchingName operatio
matchingName _ = False
document _ _ _ = return $ singleError "Missing operation name."
-operation :: MonadIO m
- => NonEmpty (Schema.Resolver m)
+operation :: Monad m
+ => HashMap Text (NonEmpty (Schema.Resolver m))
-> AST.Core.Operation
-> m Aeson.Value
-operation schema (AST.Core.Query _ flds)
- = runCollectErrs (Schema.resolve (toList schema) flds)
-operation schema (AST.Core.Mutation _ flds)
- = runCollectErrs (Schema.resolve (toList schema) flds)
+operation schema = schemaOperation
+ where
+ runResolver fields = runCollectErrs
+ . flip Schema.resolve fields
+ . Schema.resolversToMap
+ resolve fields queryType = maybe lookupError (runResolver fields)
+ $ HashMap.lookup queryType schema
+ lookupError = pure
+ $ singleError "Root operation type couldn't be found in the schema."
+ schemaOperation (AST.Core.Query _ fields) = resolve fields "Query"
+ schemaOperation (AST.Core.Mutation _ fields) = resolve fields "Mutation"
diff --git a/src/Language/GraphQL/Execute/Transform.hs b/src/Language/GraphQL/Execute/Transform.hs
index 882b324..5a9eef8 100644
--- a/src/Language/GraphQL/Execute/Transform.hs
+++ b/src/Language/GraphQL/Execute/Transform.hs
@@ -11,7 +11,7 @@ module Language.GraphQL.Execute.Transform
import Control.Arrow (first)
import Control.Monad (foldM, unless)
import Control.Monad.Trans.Class (lift)
-import Control.Monad.Trans.Reader (ReaderT, ask, runReaderT)
+import Control.Monad.Trans.Reader (ReaderT, asks, runReaderT)
import Control.Monad.Trans.State (StateT, evalStateT, gets, modify)
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
@@ -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.DefinitionOperation definition) acc =
+ defragment (ExecutableDefinition (Full.DefinitionOperation definition)) acc =
(definition :) <$> acc
- defragment (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
@@ -56,26 +58,47 @@ operations operations' = do
lift . lift $ NonEmpty.nonEmpty coreOperations
operation :: Full.OperationDefinition -> TransformT Core.Operation
-operation (Full.OperationSelectionSet sels) =
- operation $ Full.OperationDefinition Full.Query mempty mempty mempty sels
--- TODO: Validate Variable definitions with substituter
-operation (Full.OperationDefinition Full.Query name _vars _dirs sels) =
- Core.Query name <$> appendSelection sels
-operation (Full.OperationDefinition Full.Mutation name _vars _dirs sels) =
- Core.Mutation name <$> appendSelection sels
+operation (Full.SelectionSet sels)
+ = operation $ Full.OperationDefinition Full.Query mempty mempty mempty sels
+operation (Full.OperationDefinition Full.Query name _vars _dirs sels)
+ = Core.Query name <$> appendSelection sels
+operation (Full.OperationDefinition Full.Mutation name _vars _dirs sels)
+ = Core.Mutation name <$> appendSelection sels
-- * Selection
selection ::
Full.Selection ->
TransformT (Either (Seq Core.Selection) Core.Selection)
-selection (Full.SelectionField field') =
- maybe (Left mempty) (Right . Core.SelectionField) <$> field field'
-selection (Full.SelectionFragmentSpread fragment) =
- maybe (Left mempty) (Right . Core.SelectionFragment)
- <$> fragmentSpread fragment
-selection (Full.SelectionInlineFragment fragment) =
- inlineFragment fragment
+selection (Full.Field alias name arguments' directives' selections) =
+ maybe (Left mempty) (Right . Core.SelectionField) <$> do
+ fieldArguments <- arguments arguments'
+ fieldSelections <- appendSelection selections
+ fieldDirectives <- Directive.selection <$> directives directives'
+ let field' = Core.Field alias name fieldArguments fieldSelections
+ pure $ field' <$ fieldDirectives
+selection (Full.FragmentSpread name directives') =
+ maybe (Left mempty) (Right . Core.SelectionFragment) <$> do
+ spreadDirectives <- Directive.selection <$> directives directives'
+ fragments' <- gets fragments
+ fragment <- maybe lookupDefinition liftJust (HashMap.lookup name fragments')
+ pure $ fragment <$ spreadDirectives
+ where
+ lookupDefinition = do
+ fragmentDefinitions' <- gets fragmentDefinitions
+ found <- lift . lift $ HashMap.lookup name fragmentDefinitions'
+ fragmentDefinition found
+selection (Full.InlineFragment type' directives' selections) = do
+ fragmentDirectives <- Directive.selection <$> directives directives'
+ case fragmentDirectives of
+ Nothing -> pure $ Left mempty
+ _ -> do
+ fragmentSelectionSet <- appendSelection selections
+ pure $ maybe Left selectionFragment type' fragmentSelectionSet
+ where
+ selectionFragment typeName = Right
+ . Core.SelectionFragment
+ . Core.Fragment typeName
appendSelection ::
Traversable t =>
@@ -104,33 +127,6 @@ collectFragments = do
_ <- fragmentDefinition nextValue
collectFragments
-inlineFragment ::
- Full.InlineFragment ->
- TransformT (Either (Seq Core.Selection) Core.Selection)
-inlineFragment (Full.InlineFragment type' directives' selectionSet) = do
- fragmentDirectives <- Directive.selection <$> directives directives'
- case fragmentDirectives of
- Nothing -> pure $ Left mempty
- _ -> do
- fragmentSelectionSet <- appendSelection selectionSet
- pure $ maybe Left selectionFragment type' fragmentSelectionSet
- where
- selectionFragment typeName = Right
- . Core.SelectionFragment
- . Core.Fragment typeName
-
-fragmentSpread :: Full.FragmentSpread -> TransformT (Maybe Core.Fragment)
-fragmentSpread (Full.FragmentSpread name directives') = do
- spreadDirectives <- Directive.selection <$> directives directives'
- fragments' <- gets fragments
- fragment <- maybe lookupDefinition liftJust (HashMap.lookup name fragments')
- pure $ fragment <$ spreadDirectives
- where
- lookupDefinition = do
- fragmentDefinitions' <- gets fragmentDefinitions
- found <- lift . lift $ HashMap.lookup name fragmentDefinitions'
- fragmentDefinition found
-
fragmentDefinition ::
Full.FragmentDefinition ->
TransformT Core.Fragment
@@ -147,28 +143,15 @@ fragmentDefinition (Full.FragmentDefinition name type' _ selections) = do
let newFragments = HashMap.insert name newValue fragments'
in Replacement newFragments fragmentDefinitions'
-field :: Full.Field -> TransformT (Maybe Core.Field)
-field (Full.Field alias name arguments' directives' selections) = do
- fieldArguments <- traverse argument arguments'
- fieldSelections <- appendSelection selections
- fieldDirectives <- Directive.selection <$> directives directives'
- let field' = Core.Field alias name fieldArguments fieldSelections
- pure $ field' <$ fieldDirectives
-
arguments :: [Full.Argument] -> TransformT Core.Arguments
arguments = fmap Core.Arguments . foldM go HashMap.empty
where
- go arguments' argument' = do
- (Core.Argument name value') <- argument argument'
- return $ HashMap.insert name value' arguments'
-
-argument :: Full.Argument -> TransformT Core.Argument
-argument (Full.Argument n v) = Core.Argument n <$> value v
+ go arguments' (Full.Argument name value') = do
+ substitutedValue <- value value'
+ return $ HashMap.insert name substitutedValue arguments'
value :: Full.Value -> TransformT Core.Value
-value (Full.Variable n) = do
- substitute' <- lift ask
- lift . lift $ substitute' n
+value (Full.Variable name) = lift (asks $ HashMap.lookup name) >>= lift . lift
value (Full.Int i) = pure $ Core.Int i
value (Full.Float f) = pure $ Core.Float f
value (Full.String x) = pure $ Core.String x
diff --git a/src/Language/GraphQL/Schema.hs b/src/Language/GraphQL/Schema.hs
index fa8bf78..c678e48 100644
--- a/src/Language/GraphQL/Schema.hs
+++ b/src/Language/GraphQL/Schema.hs
@@ -3,28 +3,23 @@
-- | This module provides a representation of a @GraphQL@ Schema in addition to
-- functions for defining and manipulating schemas.
module Language.GraphQL.Schema
- ( Resolver
+ ( Resolver(..)
, Subs
, object
- , objectA
- , scalar
- , scalarA
, resolve
+ , resolversToMap
+ , scalar
, wrappedObject
- , wrappedObjectA
, wrappedScalar
- , wrappedScalarA
-- * AST Reexports
, Field
- , Argument(..)
, Value(..)
) where
-import Control.Monad.IO.Class (MonadIO(..))
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Except (runExceptT)
import Control.Monad.Trans.Reader (runReaderT)
-import Data.Foldable (find, fold)
+import Data.Foldable (fold, toList)
import Data.Maybe (fromMaybe)
import qualified Data.Aeson as Aeson
import Data.HashMap.Strict (HashMap)
@@ -38,81 +33,80 @@ import Language.GraphQL.Trans
import qualified Language.GraphQL.Type as Type
-- | Resolves a 'Field' into an @Aeson.@'Data.Aeson.Types.Object' with error
--- information (if an error has occurred). @m@ is usually expected to be an
--- instance of 'MonadIO'.
+-- information (if an error has occurred). @m@ is an arbitrary monad, usually
+-- 'IO'.
data Resolver m = Resolver
Text -- ^ Name
(Field -> CollectErrsT m Aeson.Object) -- ^ Resolver
--- | Variable substitution function.
-type Subs = Name -> Maybe Value
+-- | Converts resolvers to a map.
+resolversToMap
+ :: (Foldable f, Functor f)
+ => f (Resolver m)
+ -> HashMap Text (Field -> CollectErrsT m Aeson.Object)
+resolversToMap = HashMap.fromList . toList . fmap toKV
+ where
+ toKV (Resolver name f) = (name, f)
+
+-- | Contains variables for the query. The key of the map is a variable name,
+-- and the value is the variable value.
+type Subs = HashMap Name Value
-- | Create a new 'Resolver' with the given 'Name' from the given 'Resolver's.
-object :: MonadIO m => Name -> ActionT m [Resolver m] -> Resolver m
-object name = objectA name . const
-
--- | Like 'object' but also taking 'Argument's.
-objectA :: MonadIO m
- => Name -> ([Argument] -> ActionT m [Resolver m]) -> Resolver m
-objectA name f = Resolver name $ resolveFieldValue f resolveRight
+object :: Monad m => Name -> ActionT m [Resolver m] -> Resolver m
+object name f = Resolver name $ resolveFieldValue f resolveRight
where
- resolveRight fld@(Field _ _ _ flds) resolver = withField (resolve resolver flds) fld
+ resolveRight fld@(Field _ _ _ flds) resolver
+ = withField (resolve (resolversToMap resolver) flds) fld
--- | Like 'object' but also taking 'Argument's and can be null or a list of objects.
-wrappedObjectA :: MonadIO m
- => Name -> ([Argument] -> ActionT m (Type.Wrapping [Resolver m])) -> Resolver m
-wrappedObjectA name f = Resolver name $ resolveFieldValue f resolveRight
+-- | Like 'object' but can be null or a list of objects.
+wrappedObject ::
+ Monad m =>
+ Name ->
+ ActionT m (Type.Wrapping [Resolver m]) ->
+ Resolver m
+wrappedObject name f = Resolver name $ resolveFieldValue f resolveRight
where
resolveRight fld@(Field _ _ _ sels) resolver
- = withField (traverse (`resolve` sels) resolver) fld
-
--- | Like 'object' but can be null or a list of objects.
-wrappedObject :: MonadIO m
- => Name -> ActionT m (Type.Wrapping [Resolver m]) -> Resolver m
-wrappedObject name = wrappedObjectA name . const
+ = withField (traverse (resolveMap sels) resolver) fld
+ resolveMap = flip (resolve . resolversToMap)
-- | A scalar represents a primitive value, like a string or an integer.
-scalar :: (MonadIO m, Aeson.ToJSON a) => Name -> ActionT m a -> Resolver m
-scalar name = scalarA name . const
-
--- | Like 'scalar' but also taking 'Argument's.
-scalarA :: (MonadIO m, Aeson.ToJSON a)
- => Name -> ([Argument] -> ActionT m a) -> Resolver m
-scalarA name f = Resolver name $ resolveFieldValue f resolveRight
+scalar :: (Monad m, Aeson.ToJSON a) => Name -> ActionT m a -> Resolver m
+scalar name f = Resolver name $ resolveFieldValue f resolveRight
where
resolveRight fld result = withField (return result) fld
--- | Like 'scalar' but also taking 'Argument's and can be null or a list of scalars.
-wrappedScalarA :: (MonadIO m, Aeson.ToJSON a)
- => Name -> ([Argument] -> ActionT m (Type.Wrapping a)) -> Resolver m
-wrappedScalarA name f = Resolver name $ resolveFieldValue f resolveRight
+-- | Like 'scalar' but can be null or a list of scalars.
+wrappedScalar ::
+ (Monad m, Aeson.ToJSON a) =>
+ Name ->
+ ActionT m (Type.Wrapping a) ->
+ Resolver m
+wrappedScalar name f = Resolver name $ resolveFieldValue f resolveRight
where
resolveRight fld (Type.Named result) = withField (return result) fld
resolveRight fld Type.Null
= return $ HashMap.singleton (aliasOrName fld) Aeson.Null
resolveRight fld (Type.List result) = withField (return result) fld
--- | Like 'scalar' but can be null or a list of scalars.
-wrappedScalar :: (MonadIO m, Aeson.ToJSON a)
- => Name -> ActionT m (Type.Wrapping a) -> Resolver m
-wrappedScalar name = wrappedScalarA name . const
-
-resolveFieldValue :: MonadIO m
- => ([Argument] -> ActionT m a)
- -> (Field -> a -> CollectErrsT m (HashMap Text Aeson.Value))
- -> Field
- -> CollectErrsT m (HashMap Text Aeson.Value)
+resolveFieldValue ::
+ Monad m =>
+ ActionT m a ->
+ (Field -> a -> CollectErrsT m Aeson.Object) ->
+ Field ->
+ CollectErrsT m (HashMap Text Aeson.Value)
resolveFieldValue f resolveRight fld@(Field _ _ args _) = do
- result <- lift $ reader . runExceptT . runActionT $ f args
+ result <- lift $ reader . runExceptT . runActionT $ f
either resolveLeft (resolveRight fld) result
where
- reader = flip runReaderT $ Context mempty
+ reader = flip runReaderT $ Context {arguments=args}
resolveLeft err = do
_ <- addErrMsg err
return $ HashMap.singleton (aliasOrName fld) Aeson.Null
--- | Helper function to facilitate 'Argument' handling.
-withField :: (MonadIO m, Aeson.ToJSON a)
+-- | Helper function to facilitate error handling and result emitting.
+withField :: (Monad m, Aeson.ToJSON a)
=> CollectErrsT m a -> Field -> CollectErrsT m (HashMap Text Aeson.Value)
withField v fld
= HashMap.singleton (aliasOrName fld) . Aeson.toJSON <$> runAppendErrs v
@@ -120,23 +114,22 @@ withField v fld
-- | Takes a list of 'Resolver's and a list of 'Field's and applies each
-- 'Resolver' to each 'Field'. Resolves into a value containing the
-- resolved 'Field', or a null value and error information.
-resolve :: MonadIO m
- => [Resolver m] -> Seq Selection -> CollectErrsT m Aeson.Value
+resolve :: Monad m
+ => HashMap Text (Field -> CollectErrsT m Aeson.Object)
+ -> Seq Selection
+ -> CollectErrsT m Aeson.Value
resolve resolvers = fmap (Aeson.toJSON . fold) . traverse tryResolvers
where
- resolveTypeName (Resolver "__typename" f) = do
+ resolveTypeName f = do
value <- f $ Field Nothing "__typename" mempty mempty
return $ HashMap.lookupDefault "" "__typename" value
- resolveTypeName _ = return ""
tryResolvers (SelectionField fld@(Field _ name _ _))
- = maybe (errmsg fld) (tryResolver fld) $ find (compareResolvers name) resolvers
+ = fromMaybe (errmsg fld) $ HashMap.lookup name resolvers <*> Just fld
tryResolvers (SelectionFragment (Fragment typeCondition selections')) = do
- that <- traverse resolveTypeName (find (compareResolvers "__typename") resolvers)
+ that <- traverse resolveTypeName $ HashMap.lookup "__typename" resolvers
if maybe True (Aeson.String typeCondition ==) that
then fmap fold . traverse tryResolvers $ selections'
else return mempty
- compareResolvers name (Resolver name' _) = name == name'
- tryResolver fld (Resolver _ resolver) = resolver fld
errmsg fld@(Field _ name _ _) = do
addErrMsg $ T.unwords ["field", name, "not resolved."]
return $ HashMap.singleton (aliasOrName fld) Aeson.Null
diff --git a/src/Language/GraphQL/Trans.hs b/src/Language/GraphQL/Trans.hs
index 4232e75..09c012b 100644
--- a/src/Language/GraphQL/Trans.hs
+++ b/src/Language/GraphQL/Trans.hs
@@ -1,7 +1,8 @@
-- | Monad transformer stack used by the @GraphQL@ resolvers.
module Language.GraphQL.Trans
( ActionT(..)
- , Context(Context)
+ , Context(..)
+ , argument
) where
import Control.Applicative (Alternative(..))
@@ -9,13 +10,17 @@ import Control.Monad (MonadPlus(..))
import Control.Monad.IO.Class (MonadIO(..))
import Control.Monad.Trans.Class (MonadTrans(..))
import Control.Monad.Trans.Except (ExceptT)
-import Control.Monad.Trans.Reader (ReaderT)
-import Data.HashMap.Strict (HashMap)
+import Control.Monad.Trans.Reader (ReaderT, asks)
+import qualified Data.HashMap.Strict as HashMap
+import Data.Maybe (fromMaybe)
import Data.Text (Text)
-import Language.GraphQL.AST.Core (Name, Value)
+import Language.GraphQL.AST.Core
+import Prelude hiding (lookup)
-- | Resolution context holds resolver arguments.
-newtype Context = Context (HashMap Name Value)
+newtype Context = Context
+ { arguments :: Arguments
+ }
-- | Monad transformer stack used by the resolvers to provide error handling
-- and resolution context (resolver arguments).
@@ -47,3 +52,13 @@ instance Monad m => Alternative (ActionT m) where
instance Monad m => MonadPlus (ActionT m) where
mzero = empty
mplus = (<|>)
+
+-- | Retrieves an argument by its name. If the argument with this name couldn't
+-- be found, returns 'Value.Null' (i.e. the argument is assumed to
+-- be optional then).
+argument :: Monad m => Name -> ActionT m Value
+argument argumentName = do
+ argumentValue <- ActionT $ lift $ asks $ lookup . arguments
+ pure $ fromMaybe Null argumentValue
+ where
+ lookup (Arguments argumentMap) = HashMap.lookup argumentName argumentMap
generated by cgit v1.2.3 (git 2.26.2) at 2026-10-02 08:51:26 +0000