graphql 0.6.1.0 → 0.7.0.0

raw patch · 26 files changed

+1631/−660 lines, 26 filesdep +QuickCheckdep +parser-combinatorsdep ~aesondep ~containersdep ~hspec-megaparsecPVP ok

version bump matches the API change (PVP)

Dependencies added: QuickCheck, parser-combinators

Dependency ranges changed: aeson, containers, hspec-megaparsec, megaparsec, text

API changes (from Hackage documentation)

Files

• CHANGELOG.md +57/−2
• LICENSE +1/−1
• README.md +8/−1
• docs/tutorial/tutorial.lhs +11/−13
• graphql.cabal +16/−11
• src/Language/GraphQL.hs +9/−9
• src/Language/GraphQL/AST.hs +3/−182
• src/Language/GraphQL/AST/Core.hs +7/−5
• src/Language/GraphQL/AST/DirectiveLocation.hs +41/−0
• src/Language/GraphQL/AST/Document.hs +486/−0
• src/Language/GraphQL/AST/Encoder.hs +76/−40
• src/Language/GraphQL/AST/Lexer.hs +25/−17
• src/Language/GraphQL/AST/Parser.hs +366/−69
• src/Language/GraphQL/Error.hs +12/−9
• src/Language/GraphQL/Execute.hs +30/−21
• src/Language/GraphQL/Execute/Transform.hs +45/−62
• src/Language/GraphQL/Schema.hs +57/−64
• src/Language/GraphQL/Trans.hs +20/−5
• tests/Language/GraphQL/AST/EncoderSpec.hs +97/−10
• tests/Language/GraphQL/AST/LexerSpec.hs +9/−2
• tests/Language/GraphQL/AST/ParserSpec.hs +104/−4
• tests/Test/DirectiveSpec.hs +11/−7
• tests/Test/FragmentSpec.hs +8/−8
• tests/Test/StarWars/Data.hs +3/−10
• tests/Test/StarWars/QuerySpec.hs +98/−84
• tests/Test/StarWars/Schema.hs +31/−24

@@ -1,9 +1,62 @@-# Change Log+# Changelog All notable changes to this project will be documented in this file. +The format is based on+[Keep a Changelog](https://keepachangelog.com/en/1.0.0/),+and this project adheres to+[Haskell Package Versioning Policy](https://pvp.haskell.org/).++## [Unreleased]++## [0.7.0.0] - 2020-05-11+### Fixed+- Result of null encoding+- Block strings encoding+- Result of tab and newline encoding++### Added+- AST for the GraphQL schema.+- Type system definition parser.+- `Trans.argument`.+- Schema extension parser.+- Contributing guidelines.+- `Schema.resolversToMap` (intended for to be used internally).++### Changed+- Rename `AST.Definition` into `AST.Document.ExecutableDefinition`.+  `AST.Document.TypeSystemDefinition` and `AST.Document.TypeSystemExtension`+  can also be definitions.+- Move all AST data to `AST.Document` and reexport them.+- Rename `AST.OperationSelectionSet` to `AST.Document.SelectionSet`.+- Make `Schema.Subs` a `Data.HashMap.Strict` (was a function+  `key -> Maybe value` before).+- Make `AST.Lexer.at` a text (symbol) parser. It was a char before and is+  `symbol "@"` now.+- Replace `MonadIO` with a plain `Monad`. Since the tests don't use IO,+  set the inner monad to `Identity`.+- `NonEmpty (Resolver m)` is now `HashMap Text (NonEmpty (Resolver m))`. Root+  operation type can be any type, therefore a hashmap is needed. Since types+  cannot be empty, we save the list of resolvers in the type as a non-empty+  list. Currently only "Query" and "Mutation" are supported as types. For more+  schema support is required. The executor checks now if the type in the query+  matches the type of the provided root resolvers.++### Removed+- `AST.Field`, `AST.InlineFragment` and `AST.FragmentSpread`.+  These types are only used in `AST.Selection` and `AST.Selection` contains now+  3 corresponding data constructors, `Field`, `InlineFragment` and+  `FragmentSpread`, instead of separate types. It simplifies pattern matching+  and doesn't make the code less typesafe.+- `Schema.scalarA`.+- `Schema.wrappedScalarA`.+- `Schema.wrappedObjectA`.+- `Schema.objectA`.+- `AST.Argument`. Replaced with `AST.Arguments` which holds all arguments as a+  key/value map.+ ## [0.6.1.0] - 2019-12-23 ### Fixed-- Parsing multiple string arguments, such as +- Parsing multiple string arguments, such as   `login(username: "username", password: "password")` would fail on the comma   due to strings not having a space consumer. - Fragment spread is evaluated based on the `__typename` resolver. If the@@ -162,6 +215,8 @@ ### Added - Data types for the GraphQL language. +[Unreleased]: https://github.com/caraus-ecms/graphql/compare/v0.6.1.0...HEAD+[0.7.0.0]: https://github.com/caraus-ecms/graphql/compare/v0.6.1.0...v0.7.0.0 [0.6.1.0]: https://github.com/caraus-ecms/graphql/compare/v0.6.0.0...v0.6.1.0 [0.6.0.0]: https://github.com/caraus-ecms/graphql/compare/v0.5.1.0...v0.6.0.0 [0.5.1.0]: https://github.com/caraus-ecms/graphql/compare/v0.5.0.1...v0.5.1.0

@@ -1,4 +1,4 @@-Copyright 2019 Eugen Wissner, Germany+Copyright 2019-2020 Eugen Wissner, Germany Copyright 2015-2017 J. Daniel Navarro  All rights reserved.

@@ -24,10 +24,17 @@ ## Documentation  API documentation is available through-[hackage](https://hackage.haskell.org/package/graphql).+[Hackage](https://hackage.haskell.org/package/graphql).  You'll also find a small tutorial with some examples under [docs/tutorial](https://github.com/caraus-ecms/graphql/tree/master/docs/tutorial).++## Further information++- [Contributing guidelines](CONTRIBUTING.md).+- [Changelog](CHANGELOG.md) – this one contains the most recent changes; +  individual changelogs for specific versions can be found on+  [Hackage](https://hackage.haskell.org/package/graphql).  ## Contact 

@@ -12,20 +12,19 @@ Since this file is a literate haskell file, we start by importing some dependencies.  > {-# LANGUAGE OverloadedStrings #-}-> {-# LANGUAGE LambdaCase #-} > module Main where > > import Control.Monad.IO.Class (liftIO)-> import Control.Monad.Trans.Except (throwE) > import Data.Aeson (encode) > import Data.ByteString.Lazy.Char8 (putStrLn)+> import Data.HashMap.Strict (HashMap)+> import qualified Data.HashMap.Strict as HashMap > import Data.List.NonEmpty (NonEmpty(..)) > import Data.Text (Text) > import Data.Time (getCurrentTime) > > import Language.GraphQL > import qualified Language.GraphQL.Schema as Schema-> import Language.GraphQL.Trans (ActionT(..)) > > import Prelude hiding (putStrLn) @@ -36,8 +35,8 @@  First we build a GraphQL schema. -> schema1 :: NonEmpty (Schema.Resolver IO)-> schema1 = hello :| []+> schema1 :: HashMap Text (NonEmpty (Schema.Resolver IO))+> schema1 = HashMap.singleton "Query" $ hello :| [] > > hello :: Schema.Resolver IO > hello = Schema.scalar "hello" (return ("it's me" :: Text))@@ -66,14 +65,13 @@  For this example, we're going to be using time. -> schema2 :: NonEmpty (Schema.Resolver IO)-> schema2 = time :| []+> schema2 :: HashMap Text (NonEmpty (Schema.Resolver IO))+> schema2 = HashMap.singleton "Query" $ time :| [] > > time :: Schema.Resolver IO-> time = Schema.scalarA "time" $ \case->   [] -> do t <- liftIO getCurrentTime->            return $ show t->   _ -> ActionT $ throwE "Invalid arguments."+> time = Schema.scalar "time" $ do+>   t <- liftIO getCurrentTime+>   return $ show t  This defines a simple schema with one type and one field, which resolves to the current time.@@ -126,8 +124,8 @@  Now that we have two resolvers, we can define a schema which uses them both. -> schema3 :: NonEmpty (Schema.Resolver IO)-> schema3 = hello :| [time]+> schema3 :: HashMap Text (NonEmpty (Schema.Resolver IO))+> schema3 = HashMap.singleton "Query" $ hello :| [time] > > query3 :: Text > query3 = "query timeAndHello { time hello }"

@@ -1,9 +1,9 @@ cabal-version: 1.12 name: graphql-version: 0.6.1.0+version: 0.7.0.0 license: BSD3 license-file: LICENSE-copyright: (c) 2019 Eugen Wissner,+copyright: (c) 2019-2020 Eugen Wissner,            (c) 2015-2017 J. Daniel Navarro maintainer: belka@caraus.de author: Danny Navarro <j@dannynavarro.net>,@@ -34,6 +34,8 @@         Language.GraphQL         Language.GraphQL.AST         Language.GraphQL.AST.Core+        Language.GraphQL.AST.DirectiveLocation+        Language.GraphQL.AST.Document         Language.GraphQL.AST.Encoder         Language.GraphQL.AST.Lexer         Language.GraphQL.AST.Parser@@ -48,11 +50,12 @@         Language.GraphQL.Type.Directive     default-language: Haskell2010     build-depends:-        aeson >=1.4.6.0 && <1.5,+        aeson >=1.4.7.1 && <1.5,         base >=4.7 && <5,-        containers >=0.6.0.1 && <0.7,-        megaparsec >=7.0.5 && <7.1,-        text >=1.2.3.1 && <1.3,+        containers >=0.6.2.1 && <0.7,+        megaparsec >=8.0.0 && <8.1,+        parser-combinators >=1.2.1 && <1.3,+        text >=1.2.4.0 && <1.3,         transformers >=0.5.6.2 && <0.6,         unordered-containers >=0.2.10.0 && <0.3 @@ -75,15 +78,17 @@     default-language: Haskell2010     ghc-options: -threaded -rtsopts -with-rtsopts=-N     build-depends:-        aeson >=1.4.6.0 && <1.5,+        QuickCheck >=2.13.2 && <2.14,+        aeson >=1.4.7.1 && <1.5,         base >=4.7 && <5,-        containers >=0.6.0.1 && <0.7,+        containers >=0.6.2.1 && <0.7,         graphql -any,         hspec >=2.7.1 && <2.8,         hspec-expectations >=0.8.2 && <0.9,-        hspec-megaparsec >=2.0.1 && <2.1,-        megaparsec >=7.0.5 && <7.1,+        hspec-megaparsec >=2.1.0 && <2.2,+        megaparsec >=8.0.0 && <8.1,+        parser-combinators >=1.2.1 && <1.3,         raw-strings-qq ==1.1.*,-        text >=1.2.3.1 && <1.3,+        text >=1.2.4.0 && <1.3,         transformers >=0.5.6.2 && <0.6,         unordered-containers >=0.2.10.0 && <0.3

@@ -4,10 +4,10 @@     , graphqlSubs     ) where -import Control.Monad.IO.Class (MonadIO) import qualified Data.Aeson as Aeson import Data.List.NonEmpty (NonEmpty)-import qualified Data.Text as T+import Data.HashMap.Strict (HashMap)+import Data.Text (Text) import Language.GraphQL.Error import Language.GraphQL.Execute import Language.GraphQL.AST.Parser@@ -16,19 +16,19 @@  -- | If the text parses correctly as a @GraphQL@ query the query is -- executed using the given 'Schema.Resolver's.-graphql :: MonadIO m-    => NonEmpty (Schema.Resolver m) -- ^ Resolvers.-    -> T.Text -- ^ Text representing a @GraphQL@ request document.+graphql :: Monad m+    => HashMap Text (NonEmpty (Schema.Resolver m)) -- ^ Resolvers.+    -> Text -- ^ Text representing a @GraphQL@ request document.     -> m Aeson.Value -- ^ Response.-graphql = flip graphqlSubs $ const Nothing+graphql = flip graphqlSubs mempty  -- | If the text parses correctly as a @GraphQL@ query the substitution is -- applied to the query and the query is then executed using to the given -- 'Schema.Resolver's.-graphqlSubs :: MonadIO m-    => NonEmpty (Schema.Resolver m) -- ^ Resolvers.+graphqlSubs :: Monad m+    => HashMap Text (NonEmpty (Schema.Resolver m)) -- ^ Resolvers.     -> Schema.Subs -- ^ Variable substitution function.-    -> T.Text -- ^ Text representing a @GraphQL@ request document.+    -> Text -- ^ Text representing a @GraphQL@ request document.     -> m Aeson.Value -- ^ Response. graphqlSubs schema f     = either parseError (execute schema f)

@@ -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

@@ -1,7 +1,6 @@ -- | This is the AST meant to be executed. module Language.GraphQL.AST.Core     ( Alias-    , Argument(..)     , Arguments(..)     , Directive(..)     , Document@@ -35,15 +34,18 @@  -- | 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

@@ -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)

@@ -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)

@@ -15,7 +15,6 @@  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 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 @@ 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 @@     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 @@ 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 @@ 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 @@  -- * 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.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,34 +221,50 @@ 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'     | char' == '\\' = Builder.fromString "\\\\"     | 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'

@@ -15,6 +15,7 @@     , dollar     , comment     , equals+    , extend     , integer     , float     , lexeme@@ -28,20 +29,16 @@     , 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 @@                        , 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 = symbol "$"  -- | Parser for "@".-at :: Parser Char-at = char '@'+at :: Parser Text+at = symbol "@"  -- | Parser for "&". amp :: Parser T.Text@@ -134,7 +129,7 @@  -- | 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 @@  -- | 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 @@ -- | 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

@@ -6,63 +6,358 @@     ( 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 @@ -- * 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 @@     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

@@ -20,18 +20,20 @@                                  , 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 @@         , ("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.

@@ -6,14 +6,14 @@     , 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 @@ -- -- 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 @@ -- -- 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 @@     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"

@@ -11,7 +11,7 @@ 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 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 @@  -- | 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 @@     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 @@         _ <- 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 @@         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

@@ -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 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) --- | 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+-- | 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 --- | 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+-- | Create a new 'Resolver' with the given 'Name' from the given 'Resolver's.+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 @@ -- | 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

@@ -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.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 => 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

@@ -6,37 +6,124 @@  import Language.GraphQL.AST import Language.GraphQL.AST.Encoder-import Test.Hspec (Spec, context, describe, it, shouldBe)+import Test.Hspec (Spec, context, describe, it, shouldBe, shouldStartWith, shouldEndWith, shouldNotContain)+import Test.QuickCheck (choose, oneof, forAll) import Text.RawString.QQ (r)+import Data.Text.Lazy (cons, toStrict, unpack)  spec :: Spec spec = do     describe "value" $ do+        context "null value" $ do+            let testNull formatter = value formatter Null `shouldBe` "null"+            it "minified" $ testNull minified+            it "pretty" $ testNull pretty+         context "minified" $ do             it "escapes \\" $                 value minified (String "\\") `shouldBe` "\"\\\\\""-            it "escapes quotes" $+            it "escapes double quotes" $                 value minified (String "\"") `shouldBe` "\"\\\"\""+            it "escapes \\f" $+                value minified (String "\f") `shouldBe` "\"\\f\""+            it "escapes \\n" $+                value minified (String "\n") `shouldBe` "\"\\n\""+            it "escapes \\r" $+                value minified (String "\r") `shouldBe` "\"\\r\""+            it "escapes \\t" $+                value minified (String "\t") `shouldBe` "\"\\t\""             it "escapes backspace" $                 value minified (String "a\bc") `shouldBe` "\"a\\bc\""-            it "escapes Unicode" $-                value minified (String "\0") `shouldBe` "\"\\u0000\""+            context "escapes Unicode for chars less than 0010" $ do+                it "Null" $ value minified (String "\x0000") `shouldBe` "\"\\u0000\""+                it "bell" $ value minified (String "\x0007") `shouldBe` "\"\\u0007\""+            context "escapes Unicode for char less than 0020" $ do+                it "DLE" $ value minified (String "\x0010") `shouldBe` "\"\\u0010\""+                it "EM" $ value minified (String "\x0019") `shouldBe` "\"\\u0019\""+            context "encodes without escape" $ do+                it "space" $ value minified (String "\x0020") `shouldBe` "\" \""+                it "~" $ value minified (String "\x007E") `shouldBe` "\"~\""          context "pretty" $ do             it "uses strings for short string values" $                 value pretty (String "Short text") `shouldBe` "\"Short text\""-            it "uses block strings for text with new lines" $+            it "uses block strings for text with new lines, with newline symbol" $                 value pretty (String "Line 1\nLine 2")-                    `shouldBe` "\"\"\"\n  Line 1\n  Line 2\n\"\"\""-            it "escapes \\ in short strings" $-                value pretty (String "\\") `shouldBe` "\"\\\\\""+                    `shouldBe` [r|"""+  Line 1+  Line 2+"""|]+            it "uses block strings for text with new lines, with CR symbol" $+                value pretty (String "Line 1\rLine 2")+                    `shouldBe` [r|"""+  Line 1+  Line 2+"""|]+            it "uses block strings for text with new lines, with CR symbol followed by newline" $+                value pretty (String "Line 1\r\nLine 2")+                    `shouldBe` [r|"""+  Line 1+  Line 2+"""|]+            it "encodes as one line string if has escaped symbols" $ do+                let+                  genNotAllowedSymbol = oneof+                    [ choose ('\x0000', '\x0008')+                    , choose ('\x000B', '\x000C')+                    , choose ('\x000E', '\x001F')+                    , pure '\x007F'+                    ] +                forAll genNotAllowedSymbol $ \x -> do+                    let+                      rawValue = "Short \n" <> cons x "text"+                      encoded = value pretty (String $ toStrict rawValue)+                    shouldStartWith (unpack encoded) "\""+                    shouldEndWith (unpack encoded) "\""+                    shouldNotContain (unpack encoded) "\"\"\""++            it "Hello world" $ value pretty (String "Hello,\n  World!\n\nYours,\n  GraphQL.")+              `shouldBe` [r|"""+  Hello,+    World!++  Yours,+    GraphQL.+"""|]++            it "has only newlines" $ value pretty (String "\n") `shouldBe` [r|"""+++"""|]+            it "has newlines and one symbol at the begining" $+              value pretty (String "a\n\n") `shouldBe` [r|"""+  a+++"""|]+            it "has newlines and one symbol at the end" $+              value pretty (String "\n\na") `shouldBe` [r|"""+++  a+"""|]+            it "has newlines and one symbol in the middle" $+              value pretty (String "\na\n") `shouldBe` [r|"""++  a++"""|]+            it "skip trailing whitespaces" $ value pretty (String "  Short\ntext    ")+              `shouldBe` [r|"""+  Short+  text+"""|]+     describe "definition" $         it "indents block strings in arguments" $             let arguments = [Argument "message" (String "line1\nline2")]                 field = Field Nothing "field" arguments [] []-                set = OperationSelectionSet $ pure $ SelectionField field-                operation = DefinitionOperation set+                operation = DefinitionOperation $ SelectionSet $ pure field              in definition pretty operation `shouldBe` [r|{   field(message: """     line1

@@ -8,7 +8,7 @@ import Data.Void (Void) import Language.GraphQL.AST.Lexer import Test.Hspec (Spec, context, describe, it)-import Test.Hspec.Megaparsec (shouldParse, shouldSucceedOn)+import Test.Hspec.Megaparsec (shouldParse, shouldFailOn, shouldSucceedOn) import Text.Megaparsec (ParseErrorBundle, parse) import Text.RawString.QQ (r) @@ -77,7 +77,7 @@             parse spread "" "..." `shouldParse` "..."             parse colon "" ":" `shouldParse` ":"             parse equals "" "=" `shouldParse` "="-            parse at "" "@" `shouldParse` '@'+            parse at "" "@" `shouldParse` "@"             runBetween brackets `shouldSucceedOn` "[]"             runBetween braces `shouldSucceedOn` "{}"             parse pipe "" "|" `shouldParse` "|"@@ -87,6 +87,13 @@             parse blockString "" [r|""""""|] `shouldParse` ""         it "lexes ampersand" $             parse amp "" "&" `shouldParse` "&"+        it "lexes schema extensions" $+            parseExtend "schema" `shouldSucceedOn` "extend schema"+        it "fails if the given token doesn't match" $+            parseExtend "schema" `shouldFailOn` "extend shema"++parseExtend :: Text -> (Text -> Either (ParseErrorBundle Text Void) ())+parseExtend extension = parse (extend extension "" $ pure $ pure ()) ""  runBetween :: (Parser () -> Parser ()) -> Text -> Either (ParseErrorBundle Text Void) () runBetween parser = parse (parser $ pure ()) ""

@@ -4,9 +4,11 @@     ( spec     ) where +import Data.List.NonEmpty (NonEmpty(..))+import Language.GraphQL.AST.Document import Language.GraphQL.AST.Parser import Test.Hspec (Spec, describe, it)-import Test.Hspec.Megaparsec (shouldSucceedOn)+import Test.Hspec.Megaparsec (shouldParse, shouldSucceedOn) import Text.Megaparsec (parse) import Text.RawString.QQ (r) @@ -28,17 +30,115 @@     it "accepts two required arguments" $         parse document "" `shouldSucceedOn` [r|             mutation auth($username: String!, $password: String!){-                test+              test             }|]      it "accepts two string arguments" $         parse document "" `shouldSucceedOn` [r|             mutation auth{-                test(username: "username", password: "password")+              test(username: "username", password: "password")             }|]      it "accepts two block string arguments" $         parse document "" `shouldSucceedOn` [r|             mutation auth{-                test(username: """username""", password: """password""")+              test(username: """username""", password: """password""")             }|]++    it "parses minimal schema definition" $+        parse document "" `shouldSucceedOn` [r|schema { query: Query }|]++    it "parses minimal scalar definition" $+        parse document "" `shouldSucceedOn` [r|scalar Time|]++    it "parses ImplementsInterfaces" $+        parse document "" `shouldSucceedOn` [r|+            type Person implements NamedEntity & ValuedEntity {+              name: String+            }+        |]++    it "parses a  type without ImplementsInterfaces" $+        parse document "" `shouldSucceedOn` [r|+            type Person {+              name: String+            }+        |]++    it "parses ArgumentsDefinition in an ObjectDefinition" $+        parse document "" `shouldSucceedOn` [r|+            type Person {+              name(first: String, last: String): String+            }+        |]++    it "parses minimal union type definition" $+        parse document "" `shouldSucceedOn` [r|+            union SearchResult = Photo | Person+        |]++    it "parses minimal interface type definition" $+        parse document "" `shouldSucceedOn` [r|+            interface NamedEntity {+              name: String+            }+        |]++    it "parses minimal enum type definition" $+        parse document "" `shouldSucceedOn` [r|+            enum Direction {+              NORTH+              EAST+              SOUTH+              WEST+            }+        |]++    it "parses minimal enum type definition" $+        parse document "" `shouldSucceedOn` [r|+            enum Direction {+              NORTH+              EAST+              SOUTH+              WEST+            }+        |]++    it "parses minimal input object type definition" $+        parse document "" `shouldSucceedOn` [r|+            input Point2D {+              x: Float+              y: Float+            }+        |]++    it "parses minimal input enum definition with an optional pipe" $+        parse document "" `shouldSucceedOn` [r|+            directive @example on+              | FIELD+              | FRAGMENT_SPREAD+        |]++    it "parses schema extension with a new directive" $+        parse document "" `shouldSucceedOn`[r|+            extend schema @newDirective+        |]++    it "parses schema extension with an operation type definition" $+        parse document "" `shouldSucceedOn` [r|extend schema { query: Query }|]++    it "parses schema extension with an operation type and directive" $+        let newDirective = Directive "newDirective" []+            testSchemaExtension = TypeSystemExtension+                $ SchemaExtension+                $ SchemaOperationExtension [newDirective]+                $ OperationTypeDefinition Query "Query" :| []+            query = [r|extend schema @newDirective { query: Query }|]+         in parse document "" query `shouldParse` (testSchemaExtension :| [])++    it "parses an object extension" $+        parse document "" `shouldSucceedOn` [r|+            extend type Story {+              isHiddenLocally: Boolean+            }+        |]

@@ -5,14 +5,18 @@     ) where  import Data.Aeson (Value, object, (.=))+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HashMap import Data.List.NonEmpty (NonEmpty(..))+import Data.Text (Text) import Language.GraphQL import qualified Language.GraphQL.Schema as Schema import Test.Hspec (Spec, describe, it, shouldBe) import Text.RawString.QQ (r) -experimentalResolver :: Schema.Resolver IO-experimentalResolver = Schema.scalar "experimentalField" $ pure (5 :: Int) +experimentalResolver :: HashMap Text (NonEmpty (Schema.Resolver IO))+experimentalResolver = HashMap.singleton "Query"+    $ Schema.scalar "experimentalField" (pure (5 :: Int)) :| []  emptyObject :: Value emptyObject = object@@ -29,7 +33,7 @@               }             |] -            actual <- graphql (experimentalResolver :| []) query+            actual <- graphql experimentalResolver query             actual `shouldBe` emptyObject          it "should not skip fields if @skip is false" $ do@@ -44,7 +48,7 @@                         ]                     ] -            actual <- graphql (experimentalResolver :| []) query+            actual <- graphql experimentalResolver query             actual `shouldBe` expected          it "should skip fields if @include is false" $ do@@ -54,7 +58,7 @@               }             |] -            actual <- graphql (experimentalResolver :| []) query+            actual <- graphql experimentalResolver query             actual `shouldBe` emptyObject          it "should be able to @skip a fragment spread" $ do@@ -68,7 +72,7 @@               }             |] -            actual <- graphql (experimentalResolver :| []) query+            actual <- graphql experimentalResolver query             actual `shouldBe` emptyObject          it "should be able to @skip an inline fragment" $ do@@ -80,5 +84,5 @@               }             |] -            actual <- graphql (experimentalResolver :| []) query+            actual <- graphql experimentalResolver query             actual `shouldBe` emptyObject

@@ -51,7 +51,7 @@ spec = do     describe "Inline fragment executor" $ do         it "chooses the first selection if the type matches" $ do-            actual <- graphql (garment "Hat" :| []) inlineQuery+            actual <- graphql (HashMap.singleton "Query" $ garment "Hat" :| []) inlineQuery             let expected = object                     [ "data" .= object                         [ "garment" .= object@@ -62,7 +62,7 @@              in actual `shouldBe` expected          it "chooses the last selection if the type matches" $ do-            actual <- graphql (garment "Shirt" :| []) inlineQuery+            actual <- graphql (HashMap.singleton "Query" $ garment "Shirt" :| []) inlineQuery             let expected = object                     [ "data" .= object                         [ "garment" .= object@@ -83,7 +83,7 @@             }|]                 resolvers = Schema.object "garment" $ return [circumference,  size] -            actual <- graphql (resolvers :| []) query+            actual <- graphql (HashMap.singleton "Query" $ resolvers :| []) query             let expected = object                     [ "data" .= object                         [ "garment" .= object@@ -101,7 +101,7 @@               }             }|] -            actual <- graphql (size :| []) query+            actual <- graphql (HashMap.singleton "Query" $ size :| []) query             actual `shouldNotSatisfy` hasErrors      describe "Fragment spread executor" $ do@@ -116,7 +116,7 @@               }             |] -            actual <- graphql (circumference :| []) query+            actual <- graphql (HashMap.singleton "Query" $ circumference :| []) query             let expected = object                     [ "data" .= object                         [ "circumference" .= (60 :: Int)@@ -141,7 +141,7 @@               }             |] -            actual <- graphql (garment "Hat" :| []) query+            actual <- graphql (HashMap.singleton "Query" $ garment "Hat" :| []) query             let expected = object                     [ "data" .= object                         [ "garment" .= object@@ -162,7 +162,7 @@               }             |] -            actual <- graphql (circumference :| []) query+            actual <- graphql (HashMap.singleton "Query" $ circumference :| []) query             actual `shouldSatisfy` hasErrors          it "considers type condition" $ do@@ -187,5 +187,5 @@                             ]                         ]                     ]-            actual <- graphql (garment "Hat" :| []) query+            actual <- graphql (HashMap.singleton "Query" $ garment "Hat" :| []) query             actual `shouldBe` expected

@@ -8,7 +8,6 @@     , getEpisode     , getFriends     , getHero-    , getHeroIO     , getHuman     , id_     , homePlanet@@ -17,11 +16,8 @@     , typeName     ) where -import Data.Monoid (mempty)-import Control.Applicative ( Alternative(..)-                           , liftA2 -                           )-import Control.Monad.IO.Class (MonadIO(..))+import Data.Functor.Identity (Identity)+import Control.Applicative (Alternative(..), liftA2) import Control.Monad.Trans.Except (throwE) import Data.Maybe (catMaybes) import Data.Text (Text)@@ -71,7 +67,7 @@ appearsIn (Left  x) = _appearsIn . _droidChar $ x appearsIn (Right x) = _appearsIn . _humanChar $ x -secretBackstory :: MonadIO m => Character -> ActionT m Text+secretBackstory :: Character -> ActionT Identity Text secretBackstory = const $ ActionT $ throwE "secretBackstory is secret."  typeName :: Character -> Text@@ -165,9 +161,6 @@ getHero :: Int -> Character getHero 5 = luke getHero _ = artoo--getHeroIO :: Int -> IO Character-getHeroIO = pure . getHero  getHuman :: Alternative f => ID -> f Character getHuman = fmap Right . getHuman'

@@ -5,20 +5,15 @@     ) where  import qualified Data.Aeson as Aeson-import Data.Aeson ( object-                  , (.=)-                  )+import Data.Aeson ((.=))+import Data.Functor.Identity (Identity(..))+import qualified Data.HashMap.Strict as HashMap import Data.Text (Text) import Language.GraphQL import Language.GraphQL.Schema (Subs) import Text.RawString.QQ (r)-import Test.Hspec.Expectations ( Expectation-                               , shouldBe-                               )-import Test.Hspec ( Spec-                  , describe-                  , it-                  )+import Test.Hspec.Expectations (Expectation, shouldBe)+import Test.Hspec (Spec, describe, it) import Test.StarWars.Schema  -- * Test@@ -34,7 +29,11 @@             }             }         |]-        $ object [ "data" .= object ["hero" .= object ["id" .= ("2001" :: Text)]]]+        $ Aeson.object+            [ "data" .= Aeson.object+                [ "hero" .= Aeson.object ["id" .= ("2001" :: Text)]+                ]+            ]       it "R2-D2 ID and friends" $ testQuery         [r| query HeroNameAndFriendsQuery {             hero {@@ -46,14 +45,14 @@             }             }         |]-        $ object [ "data" .= object [-            "hero" .= object+        $ Aeson.object [ "data" .= Aeson.object [+            "hero" .= Aeson.object                 [ "id" .= ("2001" :: Text)                 , r2d2Name                 , "friends" .=-                    [ object [lukeName]-                    , object [hanName]-                    , object [leiaName]+                    [ Aeson.object [lukeName]+                    , Aeson.object [hanName]+                    , Aeson.object [leiaName]                     ]                 ]         ]]@@ -73,37 +72,37 @@               }             }         |]-        $ object [ "data" .= object [-          "hero" .= object [+        $ Aeson.object [ "data" .= Aeson.object [+          "hero" .= Aeson.object [               "name" .= ("R2-D2" :: Text)             , "friends" .= [-                  object [+                  Aeson.object [                       "name" .= ("Luke Skywalker" :: Text)                     , "appearsIn" .= ["NEWHOPE","EMPIRE","JEDI" :: Text]                     , "friends" .= [-                          object [hanName]-                        , object [leiaName]-                        , object [c3poName]-                        , object [r2d2Name]+                          Aeson.object [hanName]+                        , Aeson.object [leiaName]+                        , Aeson.object [c3poName]+                        , Aeson.object [r2d2Name]                         ]                     ]-                , object [+                , Aeson.object [                       hanName                     , "appearsIn" .= [ "NEWHOPE","EMPIRE","JEDI" :: Text]-                    , "friends" .= [-                          object [lukeName]-                        , object [leiaName]-                        , object [r2d2Name]+                    , "friends" .=+                        [ Aeson.object [lukeName]+                        , Aeson.object [leiaName]+                        , Aeson.object [r2d2Name]                         ]                     ]-                , object [+                , Aeson.object [                       leiaName                     , "appearsIn" .= [ "NEWHOPE","EMPIRE","JEDI" :: Text]-                    , "friends" .= [-                          object [lukeName]-                        , object [hanName]-                        , object [c3poName]-                        , object [r2d2Name]+                    , "friends" .=+                        [ Aeson.object [lukeName]+                        , Aeson.object [hanName]+                        , Aeson.object [c3poName]+                        , Aeson.object [r2d2Name]                         ]                     ]                 ]@@ -116,40 +115,40 @@               }             }         |]-        $ object [ "data" .= object [-          "human" .= object [lukeName]-        ]]+        $ Aeson.object [ "data" .= Aeson.object+            [ "human" .= Aeson.object [lukeName]+            ]]      it "Luke ID with variable" $ testQueryParams-      (\v -> if v == "someId" then Just "1000" else Nothing)+      (HashMap.singleton "someId" "1000")       [r| query FetchSomeIDQuery($someId: String!) {             human(id: $someId) {               name             }           }       |]-      $ object [ "data" .= object [-        "human" .= object [lukeName]+      $ Aeson.object [ "data" .= Aeson.object [+        "human" .= Aeson.object [lukeName]       ]]     it "Han ID with variable" $ testQueryParams-      (\v -> if v == "someId" then Just "1002" else Nothing)+      (HashMap.singleton "someId" "1002")       [r| query FetchSomeIDQuery($someId: String!) {             human(id: $someId) {               name             }           }       |]-      $ object [ "data" .= object [-        "human" .= object [hanName]+      $ Aeson.object [ "data" .= Aeson.object [+        "human" .= Aeson.object [hanName]       ]]     it "Invalid ID" $ testQueryParams-      (\v -> if v == "id" then Just "Not a valid ID" else Nothing)+      (HashMap.singleton "id" "Not a valid ID")       [r| query humanQuery($id: String!) {             human(id: $id) {               name             }           }-      |] $ object ["data" .= object ["human" .= Aeson.Null]]+      |] $ Aeson.object ["data" .= Aeson.object ["human" .= Aeson.Null]]     it "Luke aliased" $ testQuery       [r| query FetchLukeAliased {             luke: human(id: "1000") {@@ -157,8 +156,8 @@             }           }       |]-      $ object [ "data" .= object [-       "luke" .= object [lukeName]+      $ Aeson.object [ "data" .= Aeson.object [+       "luke" .= Aeson.object [lukeName]       ]]     it "R2-D2 ID and friends aliased" $ testQuery       [r| query HeroNameAndFriendsQuery {@@ -171,14 +170,14 @@             }           }       |]-      $ object [ "data" .= object [-        "hero" .= object [+      $ Aeson.object [ "data" .= Aeson.object [+        "hero" .= Aeson.object [             "id" .= ("2001" :: Text)           , r2d2Name-          , "friends" .= [-                object ["friendName" .= ("Luke Skywalker" :: Text)]-              , object ["friendName" .= ("Han Solo" :: Text)]-              , object ["friendName" .= ("Leia Organa" :: Text)]+          , "friends" .=+              [ Aeson.object ["friendName" .= ("Luke Skywalker" :: Text)]+              , Aeson.object ["friendName" .= ("Han Solo" :: Text)]+              , Aeson.object ["friendName" .= ("Leia Organa" :: Text)]               ]           ]       ]]@@ -192,9 +191,9 @@             }           }       |]-      $ object [ "data" .= object [-        "luke" .= object [lukeName]-      , "leia" .= object [leiaName]+      $ Aeson.object [ "data" .= Aeson.object+        [ "luke" .= Aeson.object [lukeName]+        , "leia" .= Aeson.object [leiaName]       ]]      describe "Fragments for complex queries" $ do@@ -210,9 +209,9 @@               }             }         |]-        $ object [ "data" .= object [-          "luke" .= object [lukeName, tatooine]-        , "leia" .= object [leiaName, alderaan]+        $ Aeson.object [ "data" .= Aeson.object [+          "luke" .= Aeson.object [lukeName, tatooine]+        , "leia" .= Aeson.object [leiaName, alderaan]         ]]       it "Fragment for duplicate content" $ testQuery         [r|  query UseFragment {@@ -228,9 +227,9 @@               homePlanet             }         |]-        $ object [ "data" .= object [-          "luke" .= object [lukeName, tatooine]-        , "leia" .= object [leiaName, alderaan]+        $ Aeson.object [ "data" .= Aeson.object [+          "luke" .= Aeson.object [lukeName, tatooine]+        , "leia" .= Aeson.object [leiaName, alderaan]         ]]      describe "__typename" $ do@@ -242,8 +241,11 @@               }             }           |]-        $ object ["data" .= object [-            "hero" .= object ["__typename" .= ("Droid" :: Text), r2d2Name]+        $ Aeson.object ["data" .= Aeson.object [+            "hero" .= Aeson.object+                [ "__typename" .= ("Droid" :: Text)+                , r2d2Name+                ]         ]]       it "Luke is a human" $ testQuery         [r| query CheckTypeOfLuke {@@ -253,8 +255,11 @@               }             }           |]-        $ object ["data" .= object [-            "hero" .= object ["__typename" .= ("Human" :: Text), lukeName]+        $ Aeson.object ["data" .= Aeson.object [+            "hero" .= Aeson.object+                [ "__typename" .= ("Human" :: Text)+                , lukeName+                ]         ]]      describe "Errors in resolvers" $ do@@ -267,15 +272,15 @@               }             }           |]-          $ object-              [ "data" .= object-                  [ "hero" .= object+          $ Aeson.object+              [ "data" .= Aeson.object+                  [ "hero" .= Aeson.object                       [ "name" .= ("R2-D2" :: Text)                       , "secretBackstory" .= Aeson.Null                       ]                   ]               , "errors" .=-                  [ object+                  [ Aeson.object                       ["message" .= ("secretBackstory is secret." :: Text)]                   ]               ]@@ -290,19 +295,19 @@                 }               }             |]-          $ object ["data" .= object-            [ "hero" .= object+          $ Aeson.object ["data" .= Aeson.object+            [ "hero" .= Aeson.object                 [ "name" .= ("R2-D2" :: Text)                 , "friends" .=-                    [ object+                    [ Aeson.object                         [ "name" .= ("Luke Skywalker" :: Text)                         , "secretBackstory" .= Aeson.Null                         ]-                    , object+                    , Aeson.object                         [ "name" .= ("Han Solo" :: Text)                         , "secretBackstory" .= Aeson.Null                         ]-                    , object+                    , Aeson.object                         [ "name" .= ("Leia Organa" :: Text)                         , "secretBackstory" .= Aeson.Null                         ]@@ -310,9 +315,15 @@                 ]             ]             , "errors" .=-                [ object ["message" .= ("secretBackstory is secret." :: Text)]-                , object ["message" .= ("secretBackstory is secret." :: Text)]-                , object ["message" .= ("secretBackstory is secret." :: Text)]+                [ Aeson.object+                    [ "message" .= ("secretBackstory is secret." :: Text)+                    ]+                , Aeson.object+                    [ "message" .= ("secretBackstory is secret." :: Text)+                    ]+                , Aeson.object+                    [ "message" .= ("secretBackstory is secret." :: Text)+                    ]                 ]             ]         it "error on secretBackstory with alias" $ testQuery@@ -323,15 +334,17 @@                 }               }             |]-          $ object-              [ "data" .= object-                  [ "mainHero" .= object+          $ Aeson.object+              [ "data" .= Aeson.object+                  [ "mainHero" .= Aeson.object                       [ "name" .= ("R2-D2" :: Text)                       , "story" .= Aeson.Null                       ]                   ]               , "errors" .=-                  [ object ["message" .= ("secretBackstory is secret." :: Text)]+                  [ Aeson.object+                    [ "message" .= ("secretBackstory is secret." :: Text)+                    ]                   ]               ] @@ -345,7 +358,8 @@     alderaan = "homePlanet" .= ("Alderaan" :: Text)  testQuery :: Text -> Aeson.Value -> Expectation-testQuery q expected = graphql schema q >>= flip shouldBe expected+testQuery q expected = runIdentity (graphql schema q) `shouldBe` expected  testQueryParams :: Subs -> Text -> Aeson.Value -> Expectation-testQueryParams f q expected = graphqlSubs schema f q >>= flip shouldBe expected+testQueryParams f q expected =+    runIdentity (graphqlSubs schema f q) `shouldBe` expected

@@ -1,4 +1,3 @@-{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} module Test.StarWars.Schema     ( character@@ -10,9 +9,12 @@  import Control.Monad.Trans.Except (throwE) import Control.Monad.Trans.Class (lift)-import Control.Monad.IO.Class (MonadIO(..))+import Data.Functor.Identity (Identity)+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HashMap import Data.List.NonEmpty (NonEmpty(..)) import Data.Maybe (catMaybes)+import Data.Text (Text) import qualified Language.GraphQL.Schema as Schema import Language.GraphQL.Trans import qualified Language.GraphQL.Type as Type@@ -20,32 +22,37 @@  -- See https://github.com/graphql/graphql-js/blob/master/src/__tests__/starWarsSchema.js -schema :: MonadIO m => NonEmpty (Schema.Resolver m)-schema = hero :| [human, droid]+schema :: HashMap Text (NonEmpty (Schema.Resolver Identity))+schema = HashMap.singleton "Query" $ hero :| [human, droid] -hero :: MonadIO m => Schema.Resolver m-hero = Schema.objectA "hero" $ \case-  [] -> character artoo-  [Schema.Argument "episode" (Schema.Enum "NEWHOPE")] -> character $ getHero 4-  [Schema.Argument "episode" (Schema.Enum "EMPIRE" )] -> character $ getHero 5-  [Schema.Argument "episode" (Schema.Enum "JEDI"   )] -> character $ getHero 6-  _ -> ActionT $ throwE "Invalid arguments."+hero :: Schema.Resolver Identity+hero = Schema.object "hero" $ do+  episode <- argument "episode"+  character $ case episode of+      Schema.Enum "NEWHOPE" -> getHero 4+      Schema.Enum "EMPIRE" -> getHero 5+      Schema.Enum "JEDI" -> getHero 6+      _ -> artoo -human :: MonadIO m => Schema.Resolver m-human = Schema.wrappedObjectA "human" $ \case-  [Schema.Argument "id" (Schema.String i)] -> do-      humanCharacter <- lift $ return $ getHuman i >>= Just-      case humanCharacter of-        Nothing -> return Type.Null-        Just e -> Type.Named <$> character e-  _ -> ActionT $ throwE "Invalid arguments."+human :: Schema.Resolver Identity+human = Schema.wrappedObject "human" $ do+    id' <- argument "id"+    case id' of+        Schema.String i -> do+            humanCharacter <- lift $ return $ getHuman i >>= Just+            case humanCharacter of+                Nothing -> return Type.Null+                Just e -> Type.Named <$> character e+        _ -> ActionT $ throwE "Invalid arguments." -droid :: MonadIO m => Schema.Resolver m-droid = Schema.objectA "droid" $ \case-   [Schema.Argument "id" (Schema.String i)] -> character =<< liftIO (getDroid i)-   _ -> ActionT $ throwE "Invalid arguments."+droid :: Schema.Resolver Identity+droid = Schema.object "droid" $ do+    id' <- argument "id"+    case id' of+        Schema.String i -> character =<< getDroid i+        _ -> ActionT $ throwE "Invalid arguments." -character :: MonadIO m => Character -> ActionT m [Schema.Resolver m]+character :: Character -> ActionT Identity [Schema.Resolver Identity] character char = return     [ Schema.scalar "id" $ return $ id_ char     , Schema.scalar "name" $ return $ name char