graphql 0.3 → 0.4.0.0

raw patch · 30 files changed

+2372/−817 lines, 30 filesdep +aesondep +hspecdep +hspec-expectationsdep −attoparsecdep −tastydep −tasty-hunitdep ~basedep ~textnew-uploaderPVP ok

version bump matches the API change (PVP)

Dependencies added: aeson, hspec, hspec-expectations, megaparsec, raw-strings-qq, transformers, unordered-containers

Dependencies removed: attoparsec, tasty, tasty-hunit

Dependency ranges changed: base, text

API changes (from Hackage documentation)

Files

• CHANGELOG.md +24/−3
• Data/GraphQL/AST.hs +0/−147
• Data/GraphQL/Encoder.hs +0/−246
• Data/GraphQL/Parser.hs +0/−336
• LICENSE +2/−1
• README.md +8/−8
• docs/tutorial/tutorial.lhs +154/−0
• graphql.cabal +77/−43
• src/Language/GraphQL.hs +36/−0
• src/Language/GraphQL/AST.hs +134/−0
• src/Language/GraphQL/AST/Core.hs +48/−0
• src/Language/GraphQL/AST/Transform.hs +120/−0
• src/Language/GraphQL/Encoder.hs +180/−0
• src/Language/GraphQL/Error.hs +83/−0
• src/Language/GraphQL/Execute.hs +42/−0
• src/Language/GraphQL/Lexer.hs +226/−0
• src/Language/GraphQL/Parser.hs +185/−0
• src/Language/GraphQL/Schema.hs +172/−0
• src/Language/GraphQL/Trans.hs +37/−0
• src/Language/GraphQL/Type.hs +57/−0
• stack.yaml +0/−5
• tests/Language/GraphQL/ErrorSpec.hs +24/−0
• tests/Language/GraphQL/LexerSpec.hs +104/−0
• tests/Language/GraphQL/ParserSpec.hs +18/−0
• tests/Spec.hs +1/−0
• tests/Test/KitchenSinkSpec.hs +29/−0
• tests/Test/StarWars/Data.hs +197/−0
• tests/Test/StarWars/QuerySpec.hs +351/−0
• tests/Test/StarWars/Schema.hs +63/−0
• tests/tasty.hs +0/−28

@@ -1,6 +1,26 @@ # Change Log All notable changes to this project will be documented in this file. +## [0.4.0.0] - 2019-07-23+### Added+- Support for mutations.+- Error handling (with monad transformers).+- Nullable types.+- Arbitrary nested lists support.+- Potential BOM header parsing.++### Changed+- attoparsec is replaced with megaparsec.+- The library is now under `Language.GraphQL` (instead of `Data.GraphQL`).+- HUnit and tasty are replaced with Hspec.+- `Alternative`/`MonadPlus` resolver constraints are replaced with `MonadIO`.++### Removed+- Duplicates from `Language.GraphQL.AST` already available in+  `Language.GraphQL.AST.Core`.+- All module exports are now explicit, so private and help functions aren't+  exported anymore.+ ## [0.3] - 2015-09-22 ### Changed - Exact match numeric types to spec.@@ -33,6 +53,7 @@ ### Added - Data types for the GraphQL language. -[0.3]: https://github.com/jdnavarro/graphql-haskell/compare/v0.2.1...v0.3-[0.2.1]: https://github.com/jdnavarro/graphql-haskell/compare/v0.2...v0.2.1-[0.2]: https://github.com/jdnavarro/graphql-haskell/compare/v0.1...v0.2+[0.4.0.0]: https://github.com/caraus-ecms/graphql/compare/v0.3...v0.4.0.0+[0.3]: https://github.com/caraus-ecms/graphql/compare/v0.2.1...v0.3+[0.2.1]: https://github.com/caraus-ecms/graphql/compare/v0.2...v0.2.1+[0.2]: https://github.com/caraus-ecms/graphql/compare/v0.1...v0.2

@@ -1,147 +0,0 @@-module Data.GraphQL.AST where--import Data.Int (Int32)-import Data.Text (Text)---- * Name--type Name = Text---- * Document--newtype Document = Document [Definition] deriving (Eq,Show)--data Definition = DefinitionOperation OperationDefinition-                | DefinitionFragment  FragmentDefinition-                | DefinitionType      TypeDefinition-                  deriving (Eq,Show)--data OperationDefinition = Query    Node-                         | Mutation Node-                           deriving (Eq,Show)--data Node = Node Name [VariableDefinition] [Directive] SelectionSet-            deriving (Eq,Show)--data VariableDefinition = VariableDefinition Variable Type (Maybe DefaultValue)-                          deriving (Eq,Show)--newtype Variable = Variable Name deriving (Eq,Show)--type SelectionSet = [Selection]--data Selection = SelectionField Field-               | SelectionFragmentSpread FragmentSpread-               | SelectionInlineFragment InlineFragment-                 deriving (Eq,Show)--data Field = Field Alias Name [Argument]-                              [Directive]-                              SelectionSet-             deriving (Eq,Show)--type Alias = Name--data Argument = Argument Name Value deriving (Eq,Show)---- * Fragments--data FragmentSpread = FragmentSpread Name [Directive]-                      deriving (Eq,Show)--data InlineFragment =-    InlineFragment TypeCondition [Directive] SelectionSet-    deriving (Eq,Show)--data FragmentDefinition =-    FragmentDefinition Name TypeCondition [Directive] SelectionSet-    deriving (Eq,Show)--type TypeCondition = NamedType---- * Values--data Value = ValueVariable Variable-           | ValueInt Int32-           -- GraphQL Float is double precison-           | ValueFloat Double-           | ValueBoolean Bool-           | ValueString StringValue-           | ValueEnum Name-           | ValueList ListValue-           | ValueObject ObjectValue-             deriving (Eq,Show)--newtype StringValue = StringValue Text deriving (Eq,Show)--newtype ListValue = ListValue [Value] deriving (Eq,Show)--newtype ObjectValue = ObjectValue [ObjectField] deriving (Eq,Show)--data ObjectField = ObjectField Name Value deriving (Eq,Show)--type DefaultValue = Value---- * Directives--data Directive = Directive Name [Argument] deriving (Eq,Show)---- * Type Reference--data Type = TypeNamed NamedType-          | TypeList ListType-          | TypeNonNull NonNullType-            deriving (Eq,Show)--newtype NamedType = NamedType Name deriving (Eq,Show)--newtype ListType = ListType Type deriving (Eq,Show)--data NonNullType = NonNullTypeNamed NamedType-                 | NonNullTypeList  ListType-                   deriving (Eq,Show)---- * Type definition--data TypeDefinition = TypeDefinitionObject        ObjectTypeDefinition-                    | TypeDefinitionInterface     InterfaceTypeDefinition-                    | TypeDefinitionUnion         UnionTypeDefinition-                    | TypeDefinitionScalar        ScalarTypeDefinition-                    | TypeDefinitionEnum          EnumTypeDefinition-                    | TypeDefinitionInputObject   InputObjectTypeDefinition-                    | TypeDefinitionTypeExtension TypeExtensionDefinition-                      deriving (Eq,Show)--data ObjectTypeDefinition = ObjectTypeDefinition Name Interfaces [FieldDefinition]-                            deriving (Eq,Show)--type Interfaces = [NamedType]--data FieldDefinition = FieldDefinition Name ArgumentsDefinition Type-                       deriving (Eq,Show)--type ArgumentsDefinition = [InputValueDefinition]--data InputValueDefinition = InputValueDefinition Name Type (Maybe DefaultValue)-                            deriving (Eq,Show)--data InterfaceTypeDefinition = InterfaceTypeDefinition Name [FieldDefinition]-                               deriving (Eq,Show)--data UnionTypeDefinition = UnionTypeDefinition Name [NamedType]-                           deriving (Eq,Show)--data ScalarTypeDefinition = ScalarTypeDefinition Name-                            deriving (Eq,Show)--data EnumTypeDefinition = EnumTypeDefinition Name [EnumValueDefinition]-                          deriving (Eq,Show)--newtype EnumValueDefinition = EnumValueDefinition Name-                              deriving (Eq,Show)--data InputObjectTypeDefinition = InputObjectTypeDefinition Name [InputValueDefinition]-                                 deriving (Eq,Show)--newtype TypeExtensionDefinition = TypeExtensionDefinition ObjectTypeDefinition-                                  deriving (Eq,Show)

@@ -1,246 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE OverloadedStrings #-}-module Data.GraphQL.Encoder where--#if !MIN_VERSION_base(4,8,0)-import Control.Applicative ((<$>))-import Data.Monoid (Monoid, mconcat, mempty)-#endif-import Data.Monoid ((<>))--import Data.Text (Text, cons, intercalate, pack, snoc)--import Data.GraphQL.AST---- * Document---- TODO: Use query shorthand-document :: Document -> Text-document (Document defs) = (`snoc` '\n') . mconcat $ definition <$> defs--definition :: Definition -> Text-definition (DefinitionOperation x) = operationDefinition x-definition (DefinitionFragment  x) = fragmentDefinition x-definition (DefinitionType      x) = typeDefinition x--operationDefinition :: OperationDefinition -> Text-operationDefinition (Query    n) = "query "    <> node n-operationDefinition (Mutation n) = "mutation " <> node n--node :: Node -> Text-node (Node name vds ds ss) =-       name-    <> optempty variableDefinitions vds-    <> optempty directives ds-    <> selectionSet ss--variableDefinitions :: [VariableDefinition] -> Text-variableDefinitions = parensCommas variableDefinition--variableDefinition :: VariableDefinition -> Text-variableDefinition (VariableDefinition var ty dv) =-    variable var <> ":" <> type_ ty <> maybe mempty defaultValue dv--defaultValue :: DefaultValue -> Text-defaultValue val = "=" <> value val--variable :: Variable -> Text-variable (Variable name) = "$" <> name--selectionSet :: SelectionSet -> Text-selectionSet = bracesCommas selection--selection :: Selection -> Text-selection (SelectionField          x) = field x-selection (SelectionInlineFragment x) = inlineFragment x-selection (SelectionFragmentSpread x) = fragmentSpread x--field :: Field -> Text-field (Field alias name args ds ss) =-       optempty (`snoc` ':') alias-    <> name-    <> optempty arguments args-    <> optempty directives ds-    <> optempty selectionSet ss--arguments :: [Argument] -> Text-arguments = parensCommas argument--argument :: Argument -> Text-argument (Argument name v) = name <> ":" <> value v---- * Fragments--fragmentSpread :: FragmentSpread -> Text-fragmentSpread (FragmentSpread name ds) =-    "..." <> name <> optempty directives ds--inlineFragment :: InlineFragment -> Text-inlineFragment (InlineFragment (NamedType tc) ds ss) =-    "... on " <> tc-              <> optempty directives ds-              <> optempty selectionSet ss--fragmentDefinition :: FragmentDefinition -> Text-fragmentDefinition (FragmentDefinition name (NamedType tc) ds ss) =-    "fragment " <> name <> " on " <> tc-                <> optempty directives ds-                <> selectionSet ss---- * Values--value :: Value -> Text-value (ValueVariable x) = variable x--- TODO: This will be replaced with `decimal` Buidler-value (ValueInt      x) = pack $ show x--- TODO: This will be replaced with `decimal` Buidler-value (ValueFloat    x) = pack $ show x-value (ValueBoolean  x) = booleanValue x-value (ValueString   x) = stringValue x-value (ValueEnum     x) = x-value (ValueList     x) = listValue x-value (ValueObject   x) = objectValue x--booleanValue :: Bool -> Text-booleanValue True  = "true"-booleanValue False = "false"---- TODO: Escape characters-stringValue :: StringValue -> Text-stringValue (StringValue v) = quotes v--listValue :: ListValue -> Text-listValue (ListValue vs) = bracketsCommas value vs--objectValue :: ObjectValue -> Text-objectValue (ObjectValue ofs) = bracesCommas objectField ofs--objectField :: ObjectField -> Text-objectField (ObjectField name v) = name <> ":" <> value v---- * Directives--directives :: [Directive] -> Text-directives = spaces directive--directive :: Directive -> Text-directive (Directive name args) = "@" <> name <> optempty arguments args---- * Type Reference--type_ :: Type -> Text-type_ (TypeNamed (NamedType x)) = x-type_ (TypeList x) = listType x-type_ (TypeNonNull x) = nonNullType x--namedType :: NamedType -> Text-namedType (NamedType name) = name--listType :: ListType -> Text-listType (ListType ty) = brackets (type_ ty)--nonNullType :: NonNullType -> Text-nonNullType (NonNullTypeNamed (NamedType x)) = x <> "!"-nonNullType (NonNullTypeList  x) = listType x <> "!"--typeDefinition :: TypeDefinition -> Text-typeDefinition (TypeDefinitionObject        x) = objectTypeDefinition x-typeDefinition (TypeDefinitionInterface     x) = interfaceTypeDefinition x-typeDefinition (TypeDefinitionUnion         x) = unionTypeDefinition x-typeDefinition (TypeDefinitionScalar        x) = scalarTypeDefinition x-typeDefinition (TypeDefinitionEnum          x) = enumTypeDefinition x-typeDefinition (TypeDefinitionInputObject   x) = inputObjectTypeDefinition x-typeDefinition (TypeDefinitionTypeExtension x) = typeExtensionDefinition x--objectTypeDefinition :: ObjectTypeDefinition -> Text-objectTypeDefinition (ObjectTypeDefinition name ifaces fds) =-    "type " <> name-            <> optempty (spaced . interfaces) ifaces-            <> optempty fieldDefinitions fds--interfaces :: Interfaces -> Text-interfaces = ("implements " <>) . spaces namedType--fieldDefinitions :: [FieldDefinition] -> Text-fieldDefinitions = bracesCommas fieldDefinition--fieldDefinition :: FieldDefinition -> Text-fieldDefinition (FieldDefinition name args ty) =-    name <> optempty argumentsDefinition args-         <> ":"-         <> type_ ty--argumentsDefinition :: ArgumentsDefinition -> Text-argumentsDefinition = parensCommas inputValueDefinition--interfaceTypeDefinition :: InterfaceTypeDefinition -> Text-interfaceTypeDefinition (InterfaceTypeDefinition name fds) =-    "interface " <> name <> fieldDefinitions fds--unionTypeDefinition :: UnionTypeDefinition -> Text-unionTypeDefinition (UnionTypeDefinition name ums) =-    "union " <> name <> "=" <> unionMembers ums--unionMembers :: [NamedType] -> Text-unionMembers = intercalate "|" . fmap namedType--scalarTypeDefinition :: ScalarTypeDefinition -> Text-scalarTypeDefinition (ScalarTypeDefinition name) = "scalar " <> name--enumTypeDefinition :: EnumTypeDefinition -> Text-enumTypeDefinition (EnumTypeDefinition name evds) =-    "enum " <> name-            <> bracesCommas enumValueDefinition evds--enumValueDefinition :: EnumValueDefinition -> Text-enumValueDefinition (EnumValueDefinition name) = name--inputObjectTypeDefinition :: InputObjectTypeDefinition -> Text-inputObjectTypeDefinition (InputObjectTypeDefinition name ivds) =-    "input " <> name <> inputValueDefinitions ivds--inputValueDefinitions :: [InputValueDefinition] -> Text-inputValueDefinitions = bracesCommas inputValueDefinition--inputValueDefinition :: InputValueDefinition -> Text-inputValueDefinition (InputValueDefinition name ty dv) =-    name <> ":" <> type_ ty <> maybe mempty defaultValue dv--typeExtensionDefinition :: TypeExtensionDefinition -> Text-typeExtensionDefinition (TypeExtensionDefinition otd) =-    "extend " <> objectTypeDefinition otd---- * Internal--spaced :: Text -> Text-spaced = cons '\SP'--between :: Char -> Char -> Text -> Text-between open close = cons open . (`snoc` close)--parens :: Text -> Text-parens = between '(' ')'--brackets :: Text -> Text-brackets = between '[' ']'--braces :: Text -> Text-braces = between '{' '}'--quotes :: Text -> Text-quotes = between '"' '"'--spaces :: (a -> Text) -> [a] -> Text-spaces f = intercalate "\SP" . fmap f--parensCommas :: (a -> Text) -> [a] -> Text-parensCommas f = parens . intercalate "," . fmap f--bracketsCommas :: (a -> Text) -> [a] -> Text-bracketsCommas f = brackets . intercalate "," . fmap f--bracesCommas :: (a -> Text) -> [a] -> Text-bracesCommas f = braces . intercalate "," . fmap f--optempty :: (Eq a, Monoid a, Monoid b) => (a -> b) -> a -> b-optempty f xs = if xs == mempty then mempty else f xs

@@ -1,336 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE OverloadedStrings #-}-module Data.GraphQL.Parser where--import Prelude hiding (takeWhile)--#if !MIN_VERSION_base(4,8,0)-import Control.Applicative ((<$>), (<*>), (*>), (<*), (<$), pure)-import Data.Monoid (Monoid, mempty)-#endif-import Control.Applicative ((<|>), empty, many, optional)-import Control.Monad (when)-import Data.Char (isDigit, isSpace)-import Data.Foldable (traverse_)--import Data.Text (Text, append)-import Data.Attoparsec.Text-  ( Parser-  , (<?>)-  , anyChar-  , decimal-  , double-  , endOfLine-  , inClass-  , many1-  , manyTill-  , option-  , peekChar-  , sepBy1-  , signed-  , takeWhile-  , takeWhile1-  )--import Data.GraphQL.AST---- * Name--name :: Parser Name-name = tok $ append <$> takeWhile1 isA_z-                    <*> takeWhile ((||) <$> isDigit <*> isA_z)-  where-    -- `isAlpha` handles many more Unicode Chars-    isA_z =  inClass $ '_' : ['A'..'Z'] ++ ['a'..'z']---- * Document--document :: Parser Document-document = whiteSpace-     *> (Document <$> many1 definition)-    -- Try SelectionSet when no definition-    <|> (Document . pure-                  . DefinitionOperation-                  . Query-                  . Node mempty empty empty-                <$> selectionSet)-    <?> "document error!"--definition :: Parser Definition-definition = DefinitionOperation <$> operationDefinition-         <|> DefinitionFragment  <$> fragmentDefinition-         <|> DefinitionType      <$> typeDefinition-         <?> "definition error!"--operationDefinition :: Parser OperationDefinition-operationDefinition =-        Query    <$ tok "query"    <*> node-    <|> Mutation <$ tok "mutation" <*> node-    <?> "operationDefinition error!"--node :: Parser Node-node = Node <$> name-            <*> optempty variableDefinitions-            <*> optempty directives-            <*> selectionSet--variableDefinitions :: Parser [VariableDefinition]-variableDefinitions = parens (many1 variableDefinition)--variableDefinition :: Parser VariableDefinition-variableDefinition =-    VariableDefinition <$> variable-                       <*  tok ":"-                       <*> type_-                       <*> optional defaultValue--defaultValue :: Parser DefaultValue-defaultValue = tok "=" *> value--variable :: Parser Variable-variable = Variable <$ tok "$" <*> name--selectionSet :: Parser SelectionSet-selectionSet = braces $ many1 selection--selection :: Parser Selection-selection = SelectionField <$> field-            -- Inline first to catch `on` case-        <|> SelectionInlineFragment <$> inlineFragment-        <|> SelectionFragmentSpread <$> fragmentSpread-        <?> "selection error!"--field :: Parser Field-field = Field <$> optempty alias-              <*> name-              <*> optempty arguments-              <*> optempty directives-              <*> optempty selectionSet--alias :: Parser Alias-alias = name <* tok ":"--arguments :: Parser [Argument]-arguments = parens $ many1 argument--argument :: Parser Argument-argument = Argument <$> name <* tok ":" <*> value---- * Fragments--fragmentSpread :: Parser FragmentSpread--- TODO: Make sure it fails when `... on`.--- See https://facebook.github.io/graphql/#FragmentSpread-fragmentSpread = FragmentSpread-    <$  tok "..."-    <*> name-    <*> optempty directives---- InlineFragment tried first in order to guard against 'on' keyword-inlineFragment :: Parser InlineFragment-inlineFragment = InlineFragment-    <$  tok "..."-    <*  tok "on"-    <*> typeCondition-    <*> optempty directives-    <*> selectionSet--fragmentDefinition :: Parser FragmentDefinition-fragmentDefinition = FragmentDefinition-    <$  tok "fragment"-    <*> name-    <*  tok "on"-    <*> typeCondition-    <*> optempty directives-    <*> selectionSet--typeCondition :: Parser TypeCondition-typeCondition = namedType---- * Values---- This will try to pick the first type it can parse. If you are working with--- explicit types use the `typedValue` parser.-value :: Parser Value-value = ValueVariable <$> variable-    -- TODO: Handle maxBound, Int32 in spec.-    <|> ValueInt      <$> tok (signed decimal)-    <|> ValueFloat    <$> tok (signed double)-    <|> ValueBoolean  <$> booleanValue-    <|> ValueString   <$> stringValue-    -- `true` and `false` have been tried before-    <|> ValueEnum     <$> name-    <|> ValueList     <$> listValue-    <|> ValueObject   <$> objectValue-    <?> "value error!"--booleanValue :: Parser Bool-booleanValue = True  <$ tok "true"-   <|> False <$ tok "false"---- TODO: Escape characters. Look at `jsstring_` in aeson package.-stringValue :: Parser StringValue-stringValue = StringValue <$> quotes (takeWhile (/= '"'))---- Notice it can be empty-listValue :: Parser ListValue-listValue = ListValue <$> brackets (many value)---- Notice it can be empty-objectValue :: Parser ObjectValue-objectValue = ObjectValue <$> braces (many objectField)--objectField :: Parser ObjectField-objectField = ObjectField <$> name <* tok ":" <*> value---- * Directives--directives :: Parser [Directive]-directives = many1 directive--directive :: Parser Directive-directive = Directive-    <$  tok "@"-    <*> name-    <*> optempty arguments---- * Type Reference--type_ :: Parser Type-type_ = TypeList    <$> listType-    <|> TypeNonNull <$> nonNullType-    <|> TypeNamed   <$> namedType-    <?> "type_ error!"--namedType :: Parser NamedType-namedType = NamedType <$> name--listType :: Parser ListType-listType = ListType <$> brackets type_--nonNullType :: Parser NonNullType-nonNullType = NonNullTypeNamed <$> namedType <* tok "!"-          <|> NonNullTypeList  <$> listType  <* tok "!"-          <?> "nonNullType error!"---- * Type Definition--typeDefinition :: Parser TypeDefinition-typeDefinition =-        TypeDefinitionObject        <$> objectTypeDefinition-    <|> TypeDefinitionInterface     <$> interfaceTypeDefinition-    <|> TypeDefinitionUnion         <$> unionTypeDefinition-    <|> TypeDefinitionScalar        <$> scalarTypeDefinition-    <|> TypeDefinitionEnum          <$> enumTypeDefinition-    <|> TypeDefinitionInputObject   <$> inputObjectTypeDefinition-    <|> TypeDefinitionTypeExtension <$> typeExtensionDefinition-    <?> "typeDefinition error!"--objectTypeDefinition :: Parser ObjectTypeDefinition-objectTypeDefinition = ObjectTypeDefinition-    <$  tok "type"-    <*> name-    <*> optempty interfaces-    <*> fieldDefinitions--interfaces :: Parser Interfaces-interfaces = tok "implements" *> many1 namedType--fieldDefinitions :: Parser [FieldDefinition]-fieldDefinitions = braces $ many1 fieldDefinition--fieldDefinition :: Parser FieldDefinition-fieldDefinition = FieldDefinition-    <$> name-    <*> optempty argumentsDefinition-    <*  tok ":"-    <*> type_--argumentsDefinition :: Parser ArgumentsDefinition-argumentsDefinition = parens $ many1 inputValueDefinition--interfaceTypeDefinition :: Parser InterfaceTypeDefinition-interfaceTypeDefinition = InterfaceTypeDefinition-    <$  tok "interface"-    <*> name-    <*> fieldDefinitions--unionTypeDefinition :: Parser UnionTypeDefinition-unionTypeDefinition = UnionTypeDefinition-    <$  tok "union"-    <*> name-    <*  tok "="-    <*> unionMembers--unionMembers :: Parser [NamedType]-unionMembers = namedType `sepBy1` tok "|"--scalarTypeDefinition :: Parser ScalarTypeDefinition-scalarTypeDefinition = ScalarTypeDefinition-    <$  tok "scalar"-    <*> name--enumTypeDefinition :: Parser EnumTypeDefinition-enumTypeDefinition = EnumTypeDefinition-    <$  tok "enum"-    <*> name-    <*> enumValueDefinitions--enumValueDefinitions :: Parser [EnumValueDefinition]-enumValueDefinitions = braces $ many1 enumValueDefinition--enumValueDefinition :: Parser EnumValueDefinition-enumValueDefinition = EnumValueDefinition <$> name--inputObjectTypeDefinition :: Parser InputObjectTypeDefinition-inputObjectTypeDefinition = InputObjectTypeDefinition-    <$  tok "input"-    <*> name-    <*> inputValueDefinitions--inputValueDefinitions :: Parser [InputValueDefinition]-inputValueDefinitions = braces $ many1 inputValueDefinition--inputValueDefinition :: Parser InputValueDefinition-inputValueDefinition = InputValueDefinition-    <$> name-    <*  tok ":"-    <*> type_-    <*> optional defaultValue--typeExtensionDefinition :: Parser TypeExtensionDefinition-typeExtensionDefinition = TypeExtensionDefinition-    <$  tok "extend"-    <*> objectTypeDefinition---- * Internal--tok :: Parser a -> Parser a-tok p = p <* whiteSpace--parens :: Parser a -> Parser a-parens = between "(" ")"--braces :: Parser a -> Parser a-braces = between "{" "}"--quotes :: Parser a -> Parser a-quotes = between "\"" "\""--brackets :: Parser a -> Parser a-brackets = between "[" "]"--between :: Parser Text -> Parser Text -> Parser a -> Parser a-between open close p = tok open *> p <* tok close---- `empty` /= `pure mempty` for `Parser`.-optempty :: Monoid a => Parser a -> Parser a-optempty = option mempty---- ** WhiteSpace----whiteSpace :: Parser ()-whiteSpace = peekChar >>= traverse_ (\c ->-    if isSpace c || c == ','-       then anyChar *> whiteSpace-       else when (c == '#') $ manyTill anyChar endOfLine *> whiteSpace)

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

@@ -1,23 +1,23 @@ # Haskell GraphQL  [![Hackage Version](https://img.shields.io/hackage/v/graphql.svg)](https://hackage.haskell.org/package/graphql)-[![Build Status](https://img.shields.io/travis/jdnavarro/graphql-haskell.svg)](https://travis-ci.org/jdnavarro/graphql-haskell)+[![Build Status](https://semaphoreci.com/api/v1/belka-ew/graphql/branches/master/badge.svg)](https://semaphoreci.com/belka-ew/graphql)+[![License](https://img.shields.io/badge/license-BSD--3--Clause-blue.svg)](https://raw.githubusercontent.com/caraus-ecms/graphql/master/LICENSE) -For now this only provides the data types to represent the GraphQL AST,-but the idea is to be a Haskell port of-[`graphql-js`](https://github.com/graphql/graphql-js). Next releases-should include:+For now this only provides a parser for the GraphQL query language and allows+to execute queries and mutations without the schema validation step.+But the idea is to be a Haskell port of+[`graphql-js`](https://github.com/graphql/graphql-js). Next releases should+include:  - [x] GraphQL AST-- [x] Parser for the GraphQL language. See TODO for limitations.+- [x] Parser for the GraphQL language. - [x] Printer for GraphQL. This is not pretty yet. - [ ] GraphQL Schema AST. - [ ] Parser for the GraphQL Schema language. - [ ] Printer for the GraphQL Schema language. - [ ] Interpreter of GraphQL requests. - [ ] Utilities to define GraphQL types and schema.--See the TODO file for more concrete tasks.  ## Contact 

@@ -0,0 +1,154 @@+---+title: GraphQL Haskell Tutorial+---+++== Getting started ==++Welcome to graphql-haskell!++We have written a small tutorial to help you (and ourselves) understand the graphql package.++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.List.NonEmpty (NonEmpty(..))+> import Data.Text (Text)+> import Data.Time (getCurrentTime)+>+> import Language.GraphQL+> import Language.GraphQL.Schema (Schema)+> import qualified Language.GraphQL.Schema as Schema+> import Language.GraphQL.Trans (ActionT(..))+>+> import Prelude hiding (putStrLn)++=== First example ===++Now, as our first example, we are going to look at the+example from [graphql.js](https://github.com/graphql/graphql-js).++First we build a GraphQL schema.++> schema1 :: Schema IO+> schema1 = hello :| []+>+> hello :: Schema.Resolver IO+> hello = Schema.scalar "hello" (return ("it's me" :: Text))++This defines a simple schema with one type and one field, that resolves to a fixed value.++Next we define our query.++> query1 :: Text+> query1 = "{ hello }"+++To run the query, we call the `graphql` with the schema and the query.++> main1 :: IO ()+> main1 = putStrLn =<< encode <$> graphql schema1 query1++This runs the query by fetching the one field defined,+returning++```{"data" : {"hello":"it's me"}}```++++=== Monadic actions ===++For this example, we're going to be using time.++> schema2 :: Schema IO+> schema2 = time :| []+>+> time :: Schema.Resolver IO+> time = Schema.scalarA "time" $ \case+>   [] -> do t <- liftIO getCurrentTime+>            return $ show t+>   _ -> ActionT $ throwE "Invalid arguments."++This defines a simple schema with one type and one field,+which resolves to the current time.++Next we define our query.++> query2 :: Text+> query2 = "{ time }"+>+> main2 :: IO ()+> main2 = putStrLn =<< encode <$> graphql schema2 query2++This runs the query, returning the current time++```{"data": {"time":"2016-03-08 23:28:14.546899 UTC"}}```+++=== Errors ===++Errors are handled according to the spec,+with fields that cause erros being resolved to `null`,+and an error being added to the error list.++An example of this is the following query:++> queryShouldFail :: Text+> queryShouldFail = "{ boyhowdy }"++Since there is no `boyhowdy` field in our schema, it will not resolve,+and the query will fail, as we can see in the following example.++> mainShouldFail :: IO ()+> mainShouldFail = do+>   success <- graphql schema1 query1+>   putStrLn $ encode success+>   putStrLn "This will fail"+>   failure <- graphql schema1 queryShouldFail+>   putStrLn $ encode failure+>++This outputs:++```+{"data": {"hello": "it's me"}}+This will fail+{"data": {"boyhowdy": null}, "errors":[{"message": "the field boyhowdy did not resolve."}]}+```++=== Combining resolvers ===++Now that we have two resolvers, we can define a schema which uses them both.++> schema3 :: Schema IO+> schema3 = hello :| [time]+>+> query3 :: Text+> query3 = "query timeAndHello { time hello }"+>+> main3 :: IO ()+> main3 = putStrLn =<< encode <$> graphql schema3 query3++This queries for both time and hello, returning++```{ "data": {"hello":"it's me","time":"2016-03-08 23:29:11.62108 UTC"}}```++Notice that we can name our queries, as we did with `timeAndHello`. Since we have only been using single queries, we can use the shorthand `{ time hello}`, as we have been doing in the previous examples.++In GraphQL there can only be one operation per query.+++== Further examples ==++More examples on queries and a more complex schema can be found in the test directory,+in the [Test.StarWars](../../tests/Test/StarWars) module. This includes a more complex schema, and more complex queries.++> main :: IO ()+> main = main1 >> main2 >> mainShouldFail >> main3

@@ -1,48 +1,82 @@-name:                graphql-version:             0.3-synopsis:            Haskell GraphQL implementation+cabal-version: 1.12+name: graphql+version: 0.4.0.0+license: BSD3+license-file: LICENSE+copyright: (c) 2019 Eugen Wissner,+           (c) 2015-2017 J. Daniel Navarro+maintainer: belka@caraus.de+author: Danny Navarro <j@dannynavarro.net>,+        Matthías Páll Gissurarson <mpg@mpg.is>,+        Sólrún Halla Einarsdóttir <she@mpg.is>+homepage: https://github.com/caraus-ecms/graphql#readme+bug-reports: https://github.com/caraus-ecms/graphql/issues+synopsis: Haskell GraphQL implementation description:-  This package provides a rudimentary parser for the-  <https://facebook.github.io/graphql/ GraphQL> language.-homepage:            https://github.com/jdnavarro/graphql-haskell-bug-reports:         https://github.com/jdnavarro/graphql-haskell/issues-license:             BSD3-license-file:        LICENSE-author:              Danny Navarro-maintainer:          j@dannynavarro.net-copyright:           Copyright (C) 2015 J. Daniel Navarro-category:            Web-build-type:          Simple-cabal-version:       >=1.10-tested-with:         GHC == 7.8.4, GHC == 7.10.2-extra-source-files:  README.md CHANGELOG.md stack.yaml-data-files:          tests/data/*.graphql-                     tests/data/*.min.graphql+    This package provides a rudimentary parser for the <https://graphql.github.io/graphql-spec/June2018/ GraphQL> language.+category: Language+build-type: Simple+data-files:+    tests/data/kitchen-sink.graphql+    tests/data/kitchen-sink.min.graphql+extra-source-files:+    CHANGELOG.md+    README.md+    LICENSE+    docs/tutorial/tutorial.lhs +source-repository head+    type: git+    location: https://github.com/caraus-ecms/graphql+ library-  default-language:    Haskell2010-  ghc-options:         -Wall-  exposed-modules:     Data.GraphQL.AST-                       Data.GraphQL.Encoder-                       Data.GraphQL.Parser-  build-depends:       base >=4.7 && < 5,-                       text >=0.11.3.1,-                       attoparsec >=0.10.4.0+    exposed-modules:+        Language.GraphQL+        Language.GraphQL.AST+        Language.GraphQL.AST.Core+        Language.GraphQL.AST.Transform+        Language.GraphQL.Encoder+        Language.GraphQL.Error+        Language.GraphQL.Execute+        Language.GraphQL.Lexer+        Language.GraphQL.Parser+        Language.GraphQL.Schema+        Language.GraphQL.Trans+        Language.GraphQL.Type+    hs-source-dirs: src+    other-modules:+        Paths_graphql+    default-language: Haskell2010+    build-depends:+        aeson >=1.4.2.0 && <1.5,+        base >=4.7 && <5,+        megaparsec >=7.0.5 && <7.1,+        text >=1.2.3.1 && <1.3,+        transformers >=0.5.6.2 && <0.6,+        unordered-containers >=0.2.10.0 && <0.3  test-suite tasty-  default-language:    Haskell2010-  type:                exitcode-stdio-1.0-  hs-source-dirs:      tests-  main-is:             tasty.hs-  ghc-options:         -Wall-  other-modules:       Paths_graphql-  build-depends:       base >=4.6 && <5,-                       text >=0.11.3.1,-                       attoparsec >=0.10.4.0,-                       tasty >=0.10,-                       tasty-hunit >=0.9,-                       graphql--source-repository head-  type:     git-  location: git://github.com/jdnavarro/graphql-haskell.git+    type: exitcode-stdio-1.0+    main-is: Spec.hs+    hs-source-dirs: tests+    other-modules:+        Language.GraphQL.ErrorSpec+        Language.GraphQL.LexerSpec+        Language.GraphQL.ParserSpec+        Test.KitchenSinkSpec+        Test.StarWars.Data+        Test.StarWars.QuerySpec+        Test.StarWars.Schema+        Paths_graphql+    default-language: Haskell2010+    ghc-options: -threaded -rtsopts -with-rtsopts=-N+    build-depends:+        aeson >=1.4.2.0 && <1.5,+        base >=4.7 && <5,+        graphql -any,+        hspec >=2.6.1 && <2.7,+        hspec-expectations >=0.8.2 && <0.9,+        megaparsec >=7.0.5 && <7.1,+        raw-strings-qq ==1.1.*,+        text >=1.2.3.1 && <1.3,+        transformers >=0.5.6.2 && <0.6

@@ -0,0 +1,36 @@+-- | This module provides the functions to parse and execute @GraphQL@ queries.+module Language.GraphQL+    ( graphql+    , graphqlSubs+    ) where++import Control.Monad.IO.Class (MonadIO)+import qualified Data.Text as T++import qualified Data.Aeson as Aeson+import Text.Megaparsec (parse)++import Language.GraphQL.Execute+import Language.GraphQL.Parser+import Language.GraphQL.Schema++import Language.GraphQL.Error++-- | Takes a 'Schema' and text representing a @GraphQL@ request document.+--   If the text parses correctly as a @GraphQL@ query the query is+--   executed according to the given 'Schema'.+--+--   Returns the response as an @Aeson.@'Aeson.Value'.+graphql :: MonadIO m => Schema m -> T.Text -> m Aeson.Value+graphql = flip graphqlSubs $ const Nothing++-- | Takes a 'Schema', a variable substitution function and text+--   representing a @GraphQL@ request document.  If the text parses+--   correctly as a @GraphQL@ query the substitution is applied to the+--   query and the query is then executed according to the given 'Schema'.+--+--   Returns the response as an @Aeson.@'Aeson.Value'.+graphqlSubs :: MonadIO m => Schema m -> Subs -> T.Text -> m Aeson.Value+graphqlSubs schema f =+    either parseError (execute schema f)+    . parse document ""

@@ -0,0 +1,134 @@+-- | 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.+module Language.GraphQL.AST+    ( Alias+    , Argument(..)+    , Arguments+    , Definition(..)+    , Directive(..)+    , Directives+    , Document+    , Field(..)+    , FragmentDefinition(..)+    , FragmentName+    , FragmentSpread(..)+    , InlineFragment(..)+    , Name+    , NonNullType(..)+    , ObjectField(..)+    , OperationDefinition(..)+    , OperationType(..)+    , Selection(..)+    , SelectionSet+    , SelectionSetOpt+    , Type(..)+    , TypeCondition+    , Value(..)+    , VariableDefinition(..)+    , VariableDefinitions+    ) where++import Data.Int (Int32)+import Data.List.NonEmpty (NonEmpty)+import Data.Text (Text)+import Language.GraphQL.AST.Core ( Alias+                                 , Name+                                 )++-- * Document++type Document = NonEmpty Definition++-- * Operations++data Definition = DefinitionOperation OperationDefinition+                | DefinitionFragment  FragmentDefinition+                  deriving (Eq,Show)++data OperationDefinition = OperationSelectionSet SelectionSet+                         | OperationDefinition   OperationType+                                                 (Maybe Name)+                                                 VariableDefinitions+                                                 Directives+                                                 SelectionSet+                           deriving (Eq,Show)++data OperationType = Query | Mutation deriving (Eq,Show)++-- * SelectionSet++type SelectionSet = NonEmpty Selection++type SelectionSetOpt = [Selection]++data Selection = SelectionField          Field+               | SelectionFragmentSpread FragmentSpread+               | SelectionInlineFragment InlineFragment+                 deriving (Eq,Show)++-- * Field++data Field = Field (Maybe Alias) Name Arguments Directives SelectionSetOpt+             deriving (Eq,Show)++-- * Arguments++type Arguments = [Argument]++data Argument = Argument Name Value deriving (Eq,Show)++-- * Fragments++data FragmentSpread = FragmentSpread Name Directives deriving (Eq,Show)++data InlineFragment = InlineFragment (Maybe TypeCondition) Directives SelectionSet+                      deriving (Eq,Show)++data FragmentDefinition =+  FragmentDefinition FragmentName TypeCondition Directives SelectionSet+  deriving (Eq,Show)++type FragmentName = Name++type TypeCondition = Name++-- * Input values++data Value = ValueVariable Name+           | ValueInt Int32+           | ValueFloat Double+           | ValueString Text+           | ValueBoolean Bool+           | ValueNull+           | ValueEnum Name+           | ValueList [Value]+           | ValueObject [ObjectField]+           deriving (Eq, Show)++data ObjectField = ObjectField Name Value deriving (Eq, Show)++-- * Variables++type VariableDefinitions = [VariableDefinition]++data VariableDefinition = VariableDefinition Name Type (Maybe Value)+                          deriving (Eq,Show)++-- * Input types++data Type = TypeNamed   Name+          | TypeList    Type+          | TypeNonNull NonNullType+            deriving (Eq,Show)++data NonNullType = NonNullTypeNamed Name+                 | NonNullTypeList  Type+                   deriving (Eq,Show)++-- * Directives++type Directives = [Directive]++data Directive = Directive Name [Argument] deriving (Eq,Show)

@@ -0,0 +1,48 @@+-- | This is the AST meant to be executed.+module Language.GraphQL.AST.Core+    ( Alias+    , Argument(..)+    , Document+    , Field(..)+    , Name+    , ObjectField(..)+    , Operation(..)+    , Value(..)+    ) where++import Data.Int (Int32)+import Data.List.NonEmpty (NonEmpty)+import Data.String++import Data.Text (Text)++-- | Name+type Name = Text++type Document = NonEmpty Operation++data Operation = Query    (NonEmpty Field)+               | Mutation (NonEmpty Field)+                 deriving (Eq,Show)++data Field = Field (Maybe Alias) Name [Argument] [Field] deriving (Eq,Show)++type Alias = Name++data Argument = Argument Name Value deriving (Eq,Show)++data Value = ValueInt Int32+           -- GraphQL Float is double precision+           | ValueFloat Double+           | ValueString Text+           | ValueBoolean Bool+           | ValueNull+           | ValueEnum Name+           | ValueList [Value]+           | ValueObject [ObjectField]+             deriving (Eq,Show)++instance IsString Value where+  fromString = ValueString . fromString++data ObjectField = ObjectField Name Value deriving (Eq,Show)

@@ -0,0 +1,120 @@+{-# LANGUAGE OverloadedStrings #-}+module Language.GraphQL.AST.Transform+    ( document+    ) where++import Control.Applicative (empty)+import Control.Monad ((<=<))+import Data.Bifunctor (first)+import Data.Either (partitionEithers)+import Data.Foldable (fold, foldMap)+import qualified Data.List.NonEmpty as NonEmpty+import Data.Monoid (Alt(Alt,getAlt), (<>))+import qualified Language.GraphQL.AST as Full+import qualified Language.GraphQL.AST.Core as Core+import qualified Language.GraphQL.Schema as Schema++-- | Replaces a fragment name by a list of 'Field'. If the name doesn't match an+--   empty list is returned.+type Fragmenter = Core.Name -> [Core.Field]++-- TODO: Replace Maybe by MonadThrow with CustomError+document :: Schema.Subs -> Full.Document -> Maybe Core.Document+document subs doc = operations subs fr ops+  where+    (fr, ops) = first foldFrags+              . partitionEithers+              . NonEmpty.toList+              $ defrag subs+            <$> doc++    foldFrags :: [Fragmenter] -> Fragmenter+    foldFrags fs n = getAlt $ foldMap (Alt . ($ n)) fs++-- * Operation++-- TODO: Replace Maybe by MonadThrow CustomError+operations+  :: Schema.Subs+  -> Fragmenter+  -> [Full.OperationDefinition]+  -> Maybe Core.Document+operations subs fr = NonEmpty.nonEmpty <=< traverse (operation subs fr)++-- TODO: Replace Maybe by MonadThrow CustomError+operation+  :: Schema.Subs+  -> Fragmenter+  -> Full.OperationDefinition+  -> Maybe Core.Operation+operation subs fr (Full.OperationSelectionSet sels) =+  operation subs fr $ Full.OperationDefinition Full.Query empty empty empty sels+-- TODO: Validate Variable definitions with substituter+operation subs fr (Full.OperationDefinition ot _n _vars _dirs sels) =+  case ot of+    Full.Query    -> Core.Query    <$> node+    Full.Mutation -> Core.Mutation <$> node+  where+    node = traverse (hush . selection subs fr) sels++selection+  :: Schema.Subs+  -> Fragmenter+  -> Full.Selection+  -> Either [Core.Field] Core.Field+selection subs fr (Full.SelectionField fld) =+  Right $ field subs fr fld+selection _    fr (Full.SelectionFragmentSpread (Full.FragmentSpread n _dirs)) =+  Left $ fr n+selection _ _  (Full.SelectionInlineFragment _)  =+  error "Inline fragments not supported yet"++-- * Fragment replacement++-- | Extract Fragments into a single Fragmenter function and a Operation+--   Definition.+defrag+  :: Schema.Subs+  -> Full.Definition+  -> Either Fragmenter Full.OperationDefinition+defrag _    (Full.DefinitionOperation op) =+  Right op+defrag subs (Full.DefinitionFragment fragDef) =+  Left $ fragmentDefinition subs fragDef++fragmentDefinition :: Schema.Subs -> Full.FragmentDefinition -> Fragmenter+fragmentDefinition subs (Full.FragmentDefinition name _tc _dirs sels) name' =+  -- TODO: Support fragments within fragments. Fold instead of map.+  if name == name'+  then either id pure =<< NonEmpty.toList (selection subs mempty <$> sels)+  else empty++field :: Schema.Subs -> Fragmenter -> Full.Field -> Core.Field+field subs fr (Full.Field a n args _dirs sels) =+    Core.Field a n (fold $ argument subs `traverse` args) (foldr go empty sels)+  where+    go :: Full.Selection -> [Core.Field] -> [Core.Field]+    go (Full.SelectionFragmentSpread (Full.FragmentSpread name _dirs)) = (fr name <>)+    go sel =  (either id pure (selection subs fr sel) <>)++argument :: Schema.Subs -> Full.Argument -> Maybe Core.Argument+argument subs (Full.Argument n v) = Core.Argument n <$> value subs v++value :: Schema.Subs -> Full.Value -> Maybe Core.Value+value subs (Full.ValueVariable n) = subs n+value _    (Full.ValueInt      i) = pure $ Core.ValueInt i+value _    (Full.ValueFloat    f) = pure $ Core.ValueFloat f+value _    (Full.ValueString   x) = pure $ Core.ValueString x+value _    (Full.ValueBoolean  b) = pure $ Core.ValueBoolean b+value _     Full.ValueNull        = pure   Core.ValueNull+value _    (Full.ValueEnum     e) = pure $ Core.ValueEnum e+value subs (Full.ValueList     l) =+  Core.ValueList   <$> traverse (value subs) l+value subs (Full.ValueObject   o) =+  Core.ValueObject <$> traverse (objectField subs) o++objectField :: Schema.Subs -> Full.ObjectField -> Maybe Core.ObjectField+objectField subs (Full.ObjectField n v) = Core.ObjectField n <$> value subs v++hush :: Either a b -> Maybe b+hush = either (const Nothing) Just

@@ -0,0 +1,180 @@+{-# LANGUAGE OverloadedStrings #-}+-- | This module defines a printer for the @GraphQL@ language.+module Language.GraphQL.Encoder+    ( document+    , spaced+    ) where++import Data.Foldable (fold)+import Data.Monoid ((<>))+import qualified Data.List.NonEmpty as NonEmpty (toList)+import Data.Text (Text, cons, intercalate, pack, snoc)+import Language.GraphQL.AST++-- * Document++document :: Document -> Text+document defs = (`snoc` '\n') . mconcat . NonEmpty.toList $ definition <$> defs++definition :: Definition -> Text+definition (DefinitionOperation x) = operationDefinition x+definition (DefinitionFragment  x) = fragmentDefinition x++operationDefinition :: OperationDefinition -> Text+operationDefinition (OperationSelectionSet sels) = selectionSet sels+operationDefinition (OperationDefinition Query    name vars dirs sels) =+  "query " <> node (fold name) vars dirs sels+operationDefinition (OperationDefinition Mutation name vars dirs sels) =+  "mutation " <> node (fold name) vars dirs sels++node :: Name -> VariableDefinitions -> Directives -> SelectionSet -> Text+node name vars dirs sels =+       name+    <> optempty variableDefinitions vars+    <> optempty directives dirs+    <> selectionSet sels++variableDefinitions :: [VariableDefinition] -> Text+variableDefinitions = parensCommas variableDefinition++variableDefinition :: VariableDefinition -> Text+variableDefinition (VariableDefinition var ty dv) =+    variable var <> ":" <> type_ ty <> maybe mempty defaultValue dv++defaultValue :: Value -> Text+defaultValue val = "=" <> value val++variable :: Name -> Text+variable var = "$" <> var++selectionSet :: SelectionSet -> Text+selectionSet = bracesCommas selection . NonEmpty.toList++selectionSetOpt :: SelectionSetOpt -> Text+selectionSetOpt = bracesCommas selection++selection :: Selection -> Text+selection (SelectionField          x) = field x+selection (SelectionInlineFragment x) = inlineFragment x+selection (SelectionFragmentSpread x) = fragmentSpread x++field :: Field -> Text+field (Field alias name args dirs selso) =+       optempty (`snoc` ':') (fold alias)+    <> name+    <> optempty arguments args+    <> optempty directives dirs+    <> optempty selectionSetOpt selso++arguments :: [Argument] -> Text+arguments = parensCommas argument++argument :: Argument -> Text+argument (Argument name v) = name <> ":" <> value v++-- * Fragments++fragmentSpread :: FragmentSpread -> Text+fragmentSpread (FragmentSpread name ds) =+    "..." <> name <> optempty directives ds++inlineFragment :: InlineFragment -> Text+inlineFragment (InlineFragment tc dirs sels) =+    "... on " <> fold tc+              <> directives dirs+              <> selectionSet sels++fragmentDefinition :: FragmentDefinition -> Text+fragmentDefinition (FragmentDefinition name tc dirs sels) =+    "fragment " <> name <> " on " <> tc+                <> optempty directives dirs+                <> selectionSet sels++-- * Values++value :: Value -> Text+value (ValueVariable x) = variable x+-- TODO: This will be replaced with `decimal` Builder+value (ValueInt      x) = pack $ show x+-- TODO: This will be replaced with `decimal` Builder+value (ValueFloat    x) = pack $ show x+value (ValueBoolean  x) = booleanValue x+value ValueNull         = mempty+value (ValueString   x) = stringValue x+value (ValueEnum     x) = x+value (ValueList     x) = listValue x+value (ValueObject   x) = objectValue x++booleanValue :: Bool -> Text+booleanValue True  = "true"+booleanValue False = "false"++-- TODO: Escape characters+stringValue :: Text -> Text+stringValue = quotes++listValue :: [Value] -> Text+listValue = bracketsCommas value++objectValue :: [ObjectField] -> Text+objectValue = bracesCommas objectField++objectField :: ObjectField -> Text+objectField (ObjectField name v) = name <> ":" <> value v++-- * Directives++directives :: [Directive] -> Text+directives = spaces directive++directive :: Directive -> Text+directive (Directive name args) = "@" <> name <> optempty arguments args++-- * Type Reference++type_ :: Type -> Text+type_ (TypeNamed   x) = x+type_ (TypeList    x) = listType x+type_ (TypeNonNull x) = nonNullType x++listType :: Type -> Text+listType x = brackets (type_ x)++nonNullType :: NonNullType -> Text+nonNullType (NonNullTypeNamed x) = x <> "!"+nonNullType (NonNullTypeList  x) = listType x <> "!"++-- * Internal++spaced :: Text -> Text+spaced = cons '\SP'++between :: Char -> Char -> Text -> Text+between open close = cons open . (`snoc` close)++parens :: Text -> Text+parens = between '(' ')'++brackets :: Text -> Text+brackets = between '[' ']'++braces :: Text -> Text+braces = between '{' '}'++quotes :: Text -> Text+quotes = between '"' '"'++spaces :: (a -> Text) -> [a] -> Text+spaces f = intercalate "\SP" . fmap f++parensCommas :: (a -> Text) -> [a] -> Text+parensCommas f = parens . intercalate "," . fmap f++bracketsCommas :: (a -> Text) -> [a] -> Text+bracketsCommas f = brackets . intercalate "," . fmap f++bracesCommas :: (a -> Text) -> [a] -> Text+bracesCommas f = braces . intercalate "," . fmap f++optempty :: (Eq a, Monoid a, Monoid b) => (a -> b) -> a -> b+optempty f xs = if xs == mempty then mempty else f xs

@@ -0,0 +1,83 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+module Language.GraphQL.Error+    ( parseError+    , CollectErrsT+    , addErr+    , addErrMsg+    , runCollectErrs+    , runAppendErrs+    , singleError+    ) where++import qualified Data.Aeson as Aeson+import Data.Text (Text)+import Data.Void (Void)+import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.State ( StateT+                                 , modify+                                 , runStateT+                                 )+import Text.Megaparsec ( ParseErrorBundle(..)+                       , 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)]+  where+    errorObject s SourcePos{..} = Aeson.object+        [ ("message", Aeson.toJSON $ init $ parseErrorTextPretty s)+        , ("line", Aeson.toJSON $ unPos sourceLine)+        , ("column", Aeson.toJSON $ unPos sourceColumn)+        ]+    go (result, state) x =+        let (sourcePosition, _, newState) = reachOffset (errorOffset x) state+         in (errorObject x sourcePosition : result, newState)++-- | A wrapper to pass error messages around.+type CollectErrsT m = StateT [Aeson.Value] m++-- | Adds an error to the list of errors.+addErr :: Monad m => Aeson.Value -> CollectErrsT m ()+addErr v = modify (v :)++makeErrorMessage :: Text -> Aeson.Value+makeErrorMessage s = Aeson.object [("message", Aeson.toJSON s)]++-- | Constructs a response object containing only the error with the given+--   message.+singleError :: Text -> Aeson.Value+singleError message = Aeson.object+    [ ("errors", Aeson.toJSON [makeErrorMessage message])+    ]++-- | Convenience function for just wrapping an error message.+addErrMsg :: Monad m => Text -> CollectErrsT m ()+addErrMsg = addErr . makeErrorMessage++-- | Appends the given list of errors to the current list of errors.+appendErrs :: Monad m => [Aeson.Value] -> CollectErrsT m ()+appendErrs errs = modify (errs ++)++-- | Runs the given query computation, but collects the errors into an error+--   list, which is then sent back with the data.+runCollectErrs :: Monad m => CollectErrsT m Aeson.Value -> m Aeson.Value+runCollectErrs res = do+    (dat, errs) <- runStateT res []+    if null errs+       then return $ Aeson.object [("data", dat)]+       else return $ Aeson.object [("data", dat), ("errors", Aeson.toJSON $ reverse errs)]++-- | Runs the given computation, collecting the errors and appending them+--   to the previous list of errors.+runAppendErrs :: Monad m => CollectErrsT m a -> CollectErrsT m a+runAppendErrs f = do+    (v, errs) <- lift $ runStateT f []+    appendErrs errs+    return v

@@ -0,0 +1,42 @@+{-# LANGUAGE OverloadedStrings #-}++-- | This module provides the function to execute a @GraphQL@ request --+--   according to a 'Schema'.+module Language.GraphQL.Execute+    ( execute+    ) where++import Control.Monad.IO.Class (MonadIO)+import qualified Data.List.NonEmpty as NE+import Data.List.NonEmpty (NonEmpty((:|)))+import qualified Data.Aeson as Aeson+import qualified Language.GraphQL.AST as AST+import qualified Language.GraphQL.AST.Core as AST.Core+import qualified Language.GraphQL.AST.Transform as Transform+import Language.GraphQL.Error+import Language.GraphQL.Schema (Schema)+import qualified Language.GraphQL.Schema as Schema++-- | Takes a 'Schema', a variable substitution function ('Schema.Subs'), and a+--   @GraphQL@ 'document'. The substitution is applied to the document using+--  'rootFields', and the 'Schema''s resolvers are applied to the resulting fields.+--+--   Returns the result of the query against the 'Schema' wrapped in a /data/ field, or+--   errors wrapped in an /errors/ field.+execute+    :: MonadIO m+    => Schema m -> Schema.Subs -> AST.Document -> m Aeson.Value+execute schema subs doc =+    maybe transformError (document schema) $ Transform.document subs doc+  where+    transformError = return $ singleError "Schema transformation error."++document :: MonadIO m => Schema m -> AST.Core.Document -> m Aeson.Value+document schema (op :| []) = operation schema op+document _ _ = return $ singleError "Multiple operations not supported yet."++operation :: MonadIO m => Schema m -> AST.Core.Operation -> m Aeson.Value+operation schema (AST.Core.Query flds)+    = runCollectErrs (Schema.resolve (NE.toList schema) (NE.toList flds))+operation schema (AST.Core.Mutation flds)+    = runCollectErrs (Schema.resolve (NE.toList schema) (NE.toList flds))

@@ -0,0 +1,226 @@+{-# LANGUAGE ExplicitForAll #-}+{-# LANGUAGE OverloadedStrings #-}++-- | This module defines a bunch of small parsers used to parse individual+--   lexemes.+module Language.GraphQL.Lexer +    ( Parser+    , amp+    , at+    , bang+    , blockString+    , braces+    , brackets+    , colon+    , dollar+    , comment+    , equals+    , integer+    , float+    , lexeme+    , name+    , parens+    , pipe+    , spaceConsumer+    , spread+    , string+    , symbol+    , unicodeBOM+    ) where++import Control.Applicative ( Alternative(..)+                           , liftA2+                           )+import Data.Char ( chr+                 , digitToInt+                 , isAsciiLower+                 , isAsciiUpper+                 , ord+                 )+import Data.Foldable (foldl')+import Data.List (dropWhileEnd)+import Data.Proxy (Proxy(..))+import Data.Void (Void)+import Text.Megaparsec ( Parsec+                       , between+                       , chunk+                       , chunkToTokens+                       , notFollowedBy+                       , oneOf+                       , option+                       , optional+                       , satisfy+                       , sepBy+                       , skipSome+                       , takeP+                       , takeWhile1P+                       , try+                       )+import Text.Megaparsec.Char ( char+                            , digitChar+                            , space1+                            )+import qualified Text.Megaparsec.Char.Lexer as Lexer+import qualified Data.Text as T+import qualified Data.Text.Lazy as TL++-- | Standard parser.+-- Accepts the type of the parsed token.+type Parser = Parsec Void T.Text++ignoredCharacters :: Parser ()+ignoredCharacters = space1 <|> skipSome (char ',')++spaceConsumer :: Parser ()+spaceConsumer = Lexer.space ignoredCharacters comment empty++-- | Parser for comments.+comment :: Parser ()+comment = Lexer.skipLineComment "#"++-- | Lexeme definition which ignores whitespaces and commas.+lexeme :: forall a. Parser a -> Parser a+lexeme = Lexer.lexeme spaceConsumer++-- | Symbol definition which ignores whitespaces and commas.+symbol :: T.Text -> Parser T.Text+symbol = Lexer.symbol spaceConsumer++-- | Parser for "!".+bang :: Parser Char+bang = char '!'++-- | Parser for "$".+dollar :: Parser Char+dollar = char '$'++-- | Parser for "@".+at :: Parser Char+at = char '@'++-- | Parser for "&".+amp :: Parser T.Text+amp = symbol "&"++-- | Parser for ":".+colon :: Parser T.Text+colon = symbol ":"++-- | Parser for "=".+equals :: Parser T.Text+equals = symbol "="++-- | Parser for the spread operator (...).+spread :: Parser T.Text+spread = symbol "..."++-- | Parser for "|".+pipe :: Parser T.Text+pipe = symbol "|"++-- | Parser for an expression between "(" and ")".+parens :: forall a. Parser a -> Parser a+parens = between (symbol "(") (symbol ")")++-- | Parser for an expression between "[" and "]".+brackets :: forall a. Parser a -> Parser a+brackets = between (symbol "[") (symbol "]")++-- | Parser for an expression between "{" and "}".+braces :: forall a. Parser a -> Parser a+braces = between (symbol "{") (symbol "}")++-- | Parser for strings.+string :: Parser T.Text+string = between "\"" "\"" stringValue+  where+    stringValue = T.pack <$> many stringCharacter+    stringCharacter = satisfy isStringCharacter1+        <|> escapeSequence+    isStringCharacter1 = liftA2 (&&) isSourceCharacter isChunkDelimiter++-- | Parser for block strings.+blockString :: Parser T.Text+blockString = between "\"\"\"" "\"\"\"" stringValue+  where+    stringValue = do+        byLine <- sepBy (many blockStringCharacter) lineTerminator+        let indentSize = foldr countIndent 0 $ tail byLine+            withoutIndent = head byLine : (removeIndent indentSize <$> tail byLine)+            withoutEmptyLines = liftA2 (.) dropWhile dropWhileEnd removeEmptyLine withoutIndent++        return $ T.intercalate "\n" $ T.concat <$> withoutEmptyLines+    removeEmptyLine [] = True+    removeEmptyLine [x] = T.null x || isWhiteSpace (T.head x)+    removeEmptyLine _ = False+    blockStringCharacter+        = takeWhile1P Nothing isWhiteSpace+        <|> takeWhile1P Nothing isBlockStringCharacter1+        <|> escapeTripleQuote+        <|> try (chunk "\"" <* notFollowedBy (chunk "\"\""))+    escapeTripleQuote = chunk "\\" >>= flip option (chunk "\"\"")+    isBlockStringCharacter1 = liftA2 (&&) isSourceCharacter isChunkDelimiter+    countIndent [] acc = acc+    countIndent (x:_) acc+        | T.null x = acc+        | not (isWhiteSpace $ T.head x) = acc+        | acc == 0 = T.length x+        | otherwise = min acc $ T.length x+    removeIndent _ [] = []+    removeIndent n (x:chunks) = T.drop n x : chunks++-- | Parser for integers.+integer :: Integral a => Parser a+integer = Lexer.signed (pure ()) $ lexeme Lexer.decimal++-- | Parser for floating-point numbers.+float :: Parser Double+float = Lexer.signed (pure ()) $ lexeme Lexer.float++-- | Parser for names (/[_A-Za-z][_0-9A-Za-z]*/).+name :: Parser T.Text+name = do+    firstLetter <- nameFirstLetter+    rest <- many $ nameFirstLetter <|> digitChar+    _ <- spaceConsumer+    return $ TL.toStrict $ TL.cons firstLetter $ TL.pack rest+      where+        nameFirstLetter = satisfy isAsciiUpper <|> satisfy isAsciiLower <|> char '_'++isChunkDelimiter :: Char -> Bool+isChunkDelimiter = flip notElem ['"', '\\', '\n', '\r']++isWhiteSpace :: Char -> Bool+isWhiteSpace = liftA2 (||) (== ' ') (== '\t')++lineTerminator :: Parser T.Text+lineTerminator = chunk "\r\n" <|> chunk "\n" <|> chunk "\r"++isSourceCharacter :: Char -> Bool+isSourceCharacter = isSourceCharacter' . ord+  where+    isSourceCharacter' code = code >= 0x0020+                           || code == 0x0009+                           || code == 0x000a+                           || code == 0x000d++escapeSequence :: Parser Char+escapeSequence = do+    _ <- char '\\'+    escaped <- oneOf ['"', '\\', '/', 'b', 'f', 'n', 'r', 't', 'u']+    case escaped of+        'b' -> return '\b'+        'f' -> return '\f'+        'n' -> return '\n'+        'r' -> return '\r'+        't' -> return '\t'+        'u' -> chr . foldl' step 0+                   . chunkToTokens (Proxy :: Proxy T.Text)+                 <$> takeP Nothing 4+        _ -> return escaped+  where+    step accumulator = (accumulator * 16 +) . digitToInt++-- | Parser for the "Byte Order Mark".+unicodeBOM :: Parser ()+unicodeBOM = optional (char '\xfeff') >> pure ()

@@ -0,0 +1,185 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+module Language.GraphQL.Parser+    ( document+    ) where++import Control.Applicative ( Alternative(..)+                           , optional+                           )+import Data.List.NonEmpty (NonEmpty(..))+import Language.GraphQL.AST+import Language.GraphQL.Lexer+import Text.Megaparsec ( lookAhead+                       , option+                       , try+                       , (<?>)+                       )++document :: Parser Document+document = unicodeBOM >> spaceConsumer >> lexeme (manyNE definition)++definition :: Parser Definition+definition = DefinitionOperation <$> operationDefinition+         <|> DefinitionFragment  <$> fragmentDefinition+         <?> "definition error!"++operationDefinition :: Parser OperationDefinition+operationDefinition = OperationSelectionSet <$> selectionSet+                  <|> OperationDefinition   <$> operationType+                                            <*> optional name+                                            <*> opt variableDefinitions+                                            <*> opt directives+                                            <*> selectionSet+                  <?> "operationDefinition error"++operationType :: Parser OperationType+operationType = Query <$ symbol "query"+    <|> Mutation <$ symbol "mutation"+    <?> "operationType error"++-- * SelectionSet++selectionSet :: Parser SelectionSet+selectionSet = braces $ manyNE selection++selectionSetOpt :: Parser SelectionSetOpt+selectionSetOpt = braces $ some selection++selection :: Parser Selection+selection = SelectionField          <$> field+        <|> try (SelectionFragmentSpread <$> fragmentSpread)+        <|> SelectionInlineFragment <$> inlineFragment+        <?> "selection error!"++-- * Field++field :: Parser Field+field = Field <$> optional alias+              <*> name+              <*> opt arguments+              <*> opt directives+              <*> opt selectionSetOpt++alias :: Parser Alias+alias = try $ name <* colon++-- * Arguments++arguments :: Parser Arguments+arguments = parens $ some argument++argument :: Parser Argument+argument = Argument <$> name <* colon <*> value++-- * Fragments++fragmentSpread :: Parser FragmentSpread+fragmentSpread = FragmentSpread <$  spread+                                <*> fragmentName+                                <*> opt directives++inlineFragment :: Parser InlineFragment+inlineFragment = InlineFragment <$  spread+                                <*> optional typeCondition+                                <*> opt directives+                                <*> selectionSet++fragmentDefinition :: Parser FragmentDefinition+fragmentDefinition = FragmentDefinition+                 <$  symbol "fragment"+                 <*> name+                 <*> typeCondition+                 <*> opt directives+                 <*> selectionSet++fragmentName :: Parser FragmentName+fragmentName = but (symbol "on") *> name++typeCondition :: Parser TypeCondition+typeCondition = symbol "on" *> name++-- * Input Values++value :: Parser Value+value = ValueVariable <$> variable+    <|> ValueFloat    <$> try float+    <|> ValueInt      <$> integer+    <|> ValueBoolean  <$> booleanValue+    <|> ValueNull     <$  symbol "null"+    <|> ValueString   <$> string+    <|> ValueString   <$> blockString+    <|> ValueEnum     <$> try enumValue+    <|> ValueList     <$> listValue+    <|> ValueObject   <$> objectValue+    <?> "value error!"+  where+    booleanValue :: Parser Bool+    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++objectField :: Parser ObjectField+objectField = ObjectField <$> name <* symbol ":" <*> value++-- * Variables++variableDefinitions :: Parser VariableDefinitions+variableDefinitions = parens $ some variableDefinition++variableDefinition :: Parser VariableDefinition+variableDefinition = VariableDefinition <$> variable+                                        <*  colon+                                        <*> type_+                                        <*> optional defaultValue+variable :: Parser Name+variable = dollar *> name++defaultValue :: Parser Value+defaultValue = equals *> value++-- * Input Types++type_ :: Parser Type+type_ = try (TypeNamed <$> name <* but "!")+    <|> TypeList       <$> brackets type_+    <|> TypeNonNull    <$> nonNullType+    <?> "type_ error!"++nonNullType :: Parser NonNullType+nonNullType = NonNullTypeNamed <$> name <* bang+          <|> NonNullTypeList  <$> brackets type_  <* bang+          <?> "nonNullType error!"++-- * Directives++directives :: Parser Directives+directives = some directive++directive :: Parser Directive+directive = Directive+        <$  at+        <*> name+        <*> opt arguments++-- * Internal++opt :: Monoid a => Parser a -> Parser a+opt = option mempty++-- 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

@@ -0,0 +1,172 @@+{-# LANGUAGE OverloadedStrings #-}++-- | This module provides a representation of a @GraphQL@ Schema in addition to+--   functions for defining and manipulating Schemas.+module Language.GraphQL.Schema+    ( Resolver+    , Schema+    , Subs+    , object+    , objectA+    , scalar+    , scalarA+    , enum+    , enumA+    , resolve+    , wrappedEnum+    , wrappedEnumA+    , 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 Data.Foldable ( find+                     , fold+                     )+import Data.List.NonEmpty (NonEmpty)+import Data.Maybe (fromMaybe)+import qualified Data.Aeson as Aeson+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HashMap+import Data.Text (Text)+import qualified Data.Text as T+import Language.GraphQL.Error+import Language.GraphQL.Trans+import Language.GraphQL.Type+import Language.GraphQL.AST.Core++-- | A GraphQL schema.+--   @m@ is usually expected to be an instance of 'MonadIO'.+type Schema m = NonEmpty (Resolver m)++-- | Resolves a 'Field' into an @Aeson.@'Aeson.Object' with error information+--   (or 'empty'). @m@ is usually expected to be an instance of 'MonadIO.+data Resolver m = Resolver+    Text -- ^ Name+    (Field -> CollectErrsT m Aeson.Object) -- ^ Resolver++type Fields = [Field]++type Arguments = [Argument]++-- | Variable substitution function.+type Subs = Name -> Maybe Value++-- | Create a new 'Resolver' with the given 'Name' from the given 'Resolver's.+object :: MonadIO m => Name -> ActionT m [Resolver m] -> Resolver m+object name = objectA name . const++-- | Like 'object' but also taking 'Argument's.+objectA :: MonadIO m+    => Name -> (Arguments -> ActionT m [Resolver m]) -> Resolver m+objectA name f = Resolver name $ resolveFieldValue f resolveRight+  where+    resolveRight fld@(Field _ _ _ flds) resolver = withField (resolve resolver flds) fld++-- | Like 'object' but also taking 'Argument's and can be null or a list of objects.+wrappedObjectA :: MonadIO m+    => Name -> (Arguments -> ActionT m (Wrapping [Resolver m])) -> Resolver m+wrappedObjectA 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 (Wrapping [Resolver m]) -> Resolver m+wrappedObject name = wrappedObjectA name . const++-- | 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 -> (Arguments -> ActionT m a) -> Resolver m+scalarA name f = Resolver name $ resolveFieldValue f resolveRight+  where+    resolveRight fld result = withField (return result) fld++-- | Lika 'scalar' but also taking 'Argument's and can be null or a list of scalars.+wrappedScalarA :: (MonadIO m, Aeson.ToJSON a)+    => Name -> (Arguments -> ActionT m (Wrapping a)) -> Resolver m+wrappedScalarA name f = Resolver name $ resolveFieldValue f resolveRight+  where+    resolveRight fld (Named result) = withField (return result) fld+    resolveRight fld Null+        = return $ HashMap.singleton (aliasOrName fld) Aeson.Null+    resolveRight fld (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 (Wrapping a) -> Resolver m+wrappedScalar name = wrappedScalarA name . const++-- | Represents one of a finite set of possible values.+--   Used in place of a 'scalar' when the possible responses are easily enumerable.+enum :: MonadIO m => Name -> ActionT m [Text] -> Resolver m+enum name = enumA name . const++-- | Like 'enum' but also taking 'Argument's.+enumA :: MonadIO m => Name -> (Arguments -> ActionT m [Text]) -> Resolver m+enumA name f = Resolver name $ resolveFieldValue f resolveRight+  where+    resolveRight fld resolver = withField (return resolver) fld++-- | Like 'enum' but also taking 'Argument's and can be null or a list of enums.+wrappedEnumA :: MonadIO m+    => Name -> (Arguments -> ActionT m (Wrapping [Text])) -> Resolver m+wrappedEnumA name f = Resolver name $ resolveFieldValue f resolveRight+  where+    resolveRight fld (Named resolver) = withField (return resolver) fld+    resolveRight fld Null+        = return $ HashMap.singleton (aliasOrName fld) Aeson.Null+    resolveRight fld (List resolver) = withField (return resolver) fld++-- | Like 'enum' but can be null or a list of enums.+wrappedEnum :: MonadIO m => Name -> ActionT m (Wrapping [Text]) -> Resolver m+wrappedEnum name = wrappedEnumA 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 f resolveRight fld@(Field _ _ args _) = do+    result <- lift $ runExceptT . runActionT $ f args+    either resolveLeft (resolveRight fld) result+      where+        resolveLeft err = do+            _ <- addErrMsg err+            return $ HashMap.singleton (aliasOrName fld) Aeson.Null++-- | Helper function to facilitate 'Argument' handling.+withField :: (MonadIO 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++-- | 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] -> Fields -> CollectErrsT m Aeson.Value+resolve resolvers = fmap (Aeson.toJSON . fold) . traverse tryResolvers+  where+    tryResolvers fld = maybe (errmsg fld) (tryResolver fld) $ find (compareResolvers fld) resolvers+    compareResolvers (Field _ 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++aliasOrName :: Field -> Text+aliasOrName (Field alias name _ _) = fromMaybe name alias

@@ -0,0 +1,37 @@+module Language.GraphQL.Trans+    ( ActionT(..)+    ) where++import Control.Applicative (Alternative(..))+import Control.Monad (MonadPlus(..))+import Control.Monad.IO.Class (MonadIO(..))+import Control.Monad.Trans.Class (MonadTrans(..))+import Control.Monad.Trans.Except (ExceptT)+import Data.Text (Text)++newtype ActionT m a = ActionT { runActionT :: ExceptT Text m a }++instance Functor m => Functor (ActionT m) where+    fmap f = ActionT . fmap f . runActionT++instance Monad m => Applicative (ActionT m) where+    pure = ActionT . pure+    (ActionT f) <*> (ActionT x) = ActionT $ f <*> x++instance Monad m => Monad (ActionT m) where+    return = pure+    (ActionT action) >>= f = ActionT $ action >>= runActionT . f++instance MonadTrans ActionT where+    lift = ActionT . lift++instance MonadIO m => MonadIO (ActionT m) where+    liftIO = lift . liftIO++instance Monad m => Alternative (ActionT m) where+    empty = ActionT empty+    (ActionT x) <|> (ActionT y) = ActionT $ x <|> y++instance Monad m => MonadPlus (ActionT m) where+    mzero = empty+    mplus = (<|>)

@@ -0,0 +1,57 @@+-- | Definitions for @GraphQL@ type system.+module Language.GraphQL.Type+    ( Wrapping(..)+    ) where++import Data.Aeson as Aeson ( ToJSON+                           , toJSON+                           )+import qualified Data.Aeson as Aeson++-- | GraphQL distinguishes between "wrapping" and "named" types. Each wrapping+--   type can wrap other wrapping or named types. Wrapping types are lists and+--   Non-Null types (named types are nullable by default).+--+--   This 'Wrapping' type doesn\'t reflect this distinction exactly but it is+--   used in the resolvers to take into account that the returned value can be+--   nullable or an (arbitrary nested) list.+data Wrapping a+    = List [Wrapping a] -- ^ Arbitrary nested list+    | Named a -- ^ Named type without further wrapping+    | Null -- ^ Null+    deriving (Eq, Show)++instance Functor Wrapping where+    fmap f (List list) = List $ fmap (fmap f) list+    fmap f (Named named) = Named $ f named+    fmap _ Null = Null++instance Foldable Wrapping where+    foldr f acc (List list) = foldr (flip $ foldr f) acc list+    foldr f acc (Named named) = f named acc+    foldr _ acc Null = acc++instance Traversable Wrapping where+    traverse f (List list) = List <$> traverse (traverse f) list+    traverse f (Named named) = Named <$> f named+    traverse _ Null = pure Null++instance Applicative Wrapping where+    pure = Named+    Null <*> _ = Null+    _ <*> Null = Null+    (Named f) <*> (Named x) = Named $ f x+    (List fs) <*> (List xs) = List $ (<*>) <$> fs <*> xs+    (Named f) <*> list = f <$> list+    (List fs) <*> named = List $ (<*> named) <$> fs++instance Monad Wrapping where+    return = pure+    Null >>= _ = Null+    (Named x) >>= f = f x+    (List xs) >>= f = List $ fmap (>>= f) xs++instance ToJSON a => ToJSON (Wrapping a) where+    toJSON (List list) = toJSON list+    toJSON (Named named) = toJSON named+    toJSON Null = Aeson.Null

@@ -1,5 +0,0 @@-flags: {}-packages:-- '.'-extra-deps: []-resolver: lts-3.4

@@ -0,0 +1,24 @@+{-# LANGUAGE OverloadedStrings #-}+module Language.GraphQL.ErrorSpec+    ( spec+    ) where++import qualified Data.Aeson as Aeson+import Language.GraphQL.Error+import Test.Hspec ( Spec+                  , describe+                  , it+                  , shouldBe+                  )++spec :: Spec+spec = describe "singleError" $+    it "constructs an error with the given message" $+        let expected = Aeson.object+                [+                    ("errors", Aeson.toJSON+                        [ Aeson.object [("message", "Message.")]+                        ]+                    )+                ]+         in singleError "Message." `shouldBe` expected

@@ -0,0 +1,104 @@+{-# LANGUAGE ExplicitForAll #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+module Language.GraphQL.LexerSpec+    ( spec+    ) where++import Data.Either (isRight)+import Data.Text (Text)+import Data.Void (Void)+import Language.GraphQL.Lexer+import Test.Hspec ( Spec+                  , context+                  , describe+                  , it+                  , shouldBe+                  , shouldSatisfy+                  )+import Text.Megaparsec ( ParseErrorBundle+                       , parse+                       )+import Text.RawString.QQ (r)++spec :: Spec+spec = describe "Lexer" $ do+    context "Reference tests" $ do+        it "accepts BOM header" $+            runParser unicodeBOM "\xfeff" `shouldSatisfy` isRight++        it "lexes strings" $ do+            runParser string [r|"simple"|] `shouldBe` Right "simple"+            runParser string [r|" white space "|] `shouldBe` Right " white space "+            runParser string [r|"quote \""|] `shouldBe` Right [r|quote "|]+            runParser string [r|"escaped \n"|] `shouldBe` Right "escaped \n"+            runParser string [r|"slashes \\ \/"|] `shouldBe` Right [r|slashes \ /|]+            runParser string [r|"unicode \u1234\u5678\u90AB\uCDEF"|]+                `shouldBe` Right "unicode ሴ噸邫췯"++        it "lexes block string" $ do+            runParser blockString [r|"""simple"""|] `shouldBe` Right "simple"+            runParser blockString [r|""" white space """|]+                `shouldBe` Right " white space "+            runParser blockString [r|"""contains " quote"""|]+                `shouldBe` Right [r|contains " quote|]+            runParser blockString [r|"""contains \""" triplequote"""|]+                `shouldBe` Right [r|contains """ triplequote|]+            runParser blockString "\"\"\"multi\nline\"\"\"" `shouldBe` Right "multi\nline"+            runParser blockString "\"\"\"multi\rline\r\nnormalized\"\"\""+                `shouldBe` Right "multi\nline\nnormalized"+            runParser blockString "\"\"\"multi\rline\r\nnormalized\"\"\""+                `shouldBe` Right "multi\nline\nnormalized"+            runParser blockString [r|"""unescaped \n\r\b\t\f\u1234"""|]+                `shouldBe` Right [r|unescaped \n\r\b\t\f\u1234|]+            runParser blockString [r|"""slashes \\ \/"""|]+                `shouldBe` Right [r|slashes \\ \/|]+            runParser blockString [r|"""++                spans+                  multiple+                    lines++                """|] `shouldBe` Right "spans\n  multiple\n    lines"++        it "lexes numbers" $ do+            runParser integer "4" `shouldBe` Right (4 :: Int)+            runParser float "4.123" `shouldBe` Right 4.123+            runParser integer "-4" `shouldBe` Right (-4 :: Int)+            runParser integer "9" `shouldBe` Right (9 :: Int)+            runParser integer "0" `shouldBe` Right (0 :: Int)+            runParser float "-4.123" `shouldBe` Right (-4.123)+            runParser float "0.123" `shouldBe` Right 0.123+            runParser float "123e4" `shouldBe` Right 123e4+            runParser float "123E4" `shouldBe` Right 123E4+            runParser float "123e-4" `shouldBe` Right 123e-4+            runParser float "123e+4" `shouldBe` Right 123e+4+            runParser float "-1.123e4" `shouldBe` Right (-1.123e4)+            runParser float "-1.123E4" `shouldBe` Right (-1.123E4)+            runParser float "-1.123e-4" `shouldBe` Right (-1.123e-4)+            runParser float "-1.123e+4" `shouldBe` Right (-1.123e+4)+            runParser float "-1.123e4567" `shouldBe` Right (-1.123e4567)++        it "lexes punctuation" $ do+            runParser bang "!" `shouldBe` Right '!'+            runParser dollar "$" `shouldBe` Right '$'+            runBetween parens "()" `shouldSatisfy` isRight+            runParser spread "..." `shouldBe` Right "..."+            runParser colon ":" `shouldBe` Right ":"+            runParser equals "=" `shouldBe` Right "="+            runParser at "@" `shouldBe` Right '@'+            runBetween brackets "[]" `shouldSatisfy` isRight+            runBetween braces "{}" `shouldSatisfy` isRight+            runParser pipe "|" `shouldBe` Right "|"++    context "Implementation tests" $ do+        it "lexes empty block strings" $+            runParser blockString [r|""""""|] `shouldBe` Right ""+        it "lexes ampersand" $+            runParser amp "&" `shouldBe` Right "&"++runParser :: forall a. Parser a -> Text -> Either (ParseErrorBundle Text Void) a+runParser = flip parse ""++runBetween :: (Parser () -> Parser ()) -> Text -> Either (ParseErrorBundle Text Void) ()+runBetween parser = parse (parser $ pure ()) ""

@@ -0,0 +1,18 @@+{-# LANGUAGE OverloadedStrings #-}+module Language.GraphQL.ParserSpec+    ( spec+    ) where++import Data.Either (isRight)+import Language.GraphQL.Parser (document)+import Test.Hspec ( Spec+                  , describe+                  , it+                  , shouldSatisfy+                  )+import Text.Megaparsec (parse)++spec :: Spec+spec = describe "Parser" $+    it "accepts BOM header" $+        parse document "" "\xfeff{foo}" `shouldSatisfy` isRight

@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}

@@ -0,0 +1,29 @@+module Test.KitchenSinkSpec+    ( spec+    ) where++import qualified Data.Text.IO as Text.IO+import qualified Language.GraphQL.Encoder as Encoder+import qualified Language.GraphQL.Parser as Parser+import Paths_graphql (getDataFileName)+import Test.Hspec ( Spec+                  , describe+                  , it+                  )+import Test.Hspec.Expectations ( expectationFailure+                               , shouldBe+                               )+import Text.Megaparsec ( errorBundlePretty+                       , parse+                       )++spec :: Spec+spec = describe "Kitchen Sink" $+    it "prints the query" $ do+        dataFileName <- getDataFileName "tests/data/kitchen-sink.min.graphql"+        expected <- Text.IO.readFile dataFileName++        either+            (expectationFailure . errorBundlePretty)+            (flip shouldBe expected . Encoder.document)+            $ parse Parser.document dataFileName expected

@@ -0,0 +1,197 @@+{-# LANGUAGE OverloadedStrings #-}+module Test.StarWars.Data+    ( Character+    , appearsIn+    , artoo+    , getDroid+    , getDroid'+    , getEpisode+    , getFriends+    , getHero+    , getHeroIO+    , getHuman+    , id_+    , homePlanet+    , name+    , secretBackstory+    , typeName+    ) where++import Data.Monoid (mempty)+import Control.Applicative ( Alternative(..)+                           , liftA2 +                           )+import Control.Monad.IO.Class (MonadIO(..))+import Control.Monad.Trans.Except (throwE)+import Data.Maybe (catMaybes)+import Data.Text (Text)+import Language.GraphQL.Trans++-- * Data+-- See https://github.com/graphql/graphql-js/blob/master/src/__tests__/starWarsData.js++-- ** Characters++type ID = Text++data CharCommon = CharCommon+  { _id_        :: ID+  , _name       :: Text+  , _friends    :: [ID]+  , _appearsIn  :: [Int]+  } deriving (Show)+++data Human = Human+  { _humanChar  :: CharCommon+  , homePlanet :: Text+  }++data Droid = Droid+  { _droidChar       :: CharCommon+  , primaryFunction :: Text+  }++type Character = Either Droid Human++id_ :: Character -> ID+id_ (Left  x) = _id_ . _droidChar $ x+id_ (Right x) = _id_ . _humanChar $ x++name :: Character -> Text+name (Left  x) = _name . _droidChar $ x+name (Right x) = _name . _humanChar $ x++friends :: Character -> [ID]+friends (Left  x) = _friends . _droidChar $ x+friends (Right x) = _friends . _humanChar $ x++appearsIn :: Character -> [Int]+appearsIn (Left  x) = _appearsIn . _droidChar $ x+appearsIn (Right x) = _appearsIn . _humanChar $ x++secretBackstory :: MonadIO m => Character -> ActionT m Text+secretBackstory = const $ ActionT $ throwE "secretBackstory is secret."++typeName :: Character -> Text+typeName = either (const "Droid") (const "Human")++luke :: Character+luke = Right luke'++luke' :: Human+luke' = Human+  { _humanChar = CharCommon+      { _id_        = "1000"+      , _name       = "Luke Skywalker"+      , _friends    = ["1002","1003","2000","2001"]+      , _appearsIn  = [4,5,6]+      }+  , homePlanet = "Tatooine"+  }++vader :: Human+vader = Human+  { _humanChar = CharCommon+      { _id_        = "1001"+      , _name       = "Darth Vader"+      , _friends    = ["1004"]+      , _appearsIn  = [4,5,6]+      }+  , homePlanet = "Tatooine"+  }++han :: Human+han = Human+  { _humanChar = CharCommon+      { _id_        = "1002"+      , _name       = "Han Solo"+      , _friends    = ["1000","1003","2001" ]+      , _appearsIn  = [4,5,6]+      }+  , homePlanet = mempty+  }++leia :: Human+leia = Human+  { _humanChar = CharCommon+      { _id_        = "1003"+      , _name       = "Leia Organa"+      , _friends    = ["1000","1002","2000","2001"]+      , _appearsIn  = [4,5,6]+      }+  , homePlanet = "Alderaan"+  }++tarkin :: Human+tarkin = Human+  { _humanChar = CharCommon+    { _id_        = "1004"+    , _name       = "Wilhuff Tarkin"+    , _friends    = ["1001"]+    , _appearsIn  = [4]+    }+  , homePlanet = mempty+  }++threepio :: Droid+threepio = Droid+  { _droidChar = CharCommon+      { _id_ = "2000"+      , _name = "C-3PO"+      , _friends = ["1000","1002","1003","2001" ]+      , _appearsIn = [ 4, 5, 6 ]+      }+  , primaryFunction = "Protocol"+  }++artoo :: Character+artoo = Left artoo'++artoo' :: Droid+artoo' = Droid+  { _droidChar = CharCommon+      { _id_        = "2001"+      , _name       = "R2-D2"+      , _friends    = ["1000","1002","1003"]+      , _appearsIn  = [4,5,6]+      }+  , primaryFunction = "Astrometch"+  }++-- ** Helper functions++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'++getHuman' :: Alternative f => ID -> f Human+getHuman' "1000" = pure luke'+getHuman' "1001" = pure vader+getHuman' "1002" = pure han+getHuman' "1003" = pure leia+getHuman' "1004" = pure tarkin+getHuman' _      = empty++getDroid :: Alternative f => ID -> f Character+getDroid = fmap Left . getDroid'++getDroid' :: Alternative f => ID -> f Droid+getDroid' "2000" = pure threepio+getDroid' "2001" = pure artoo'+getDroid' _      = empty++getFriends :: Character -> [Character]+getFriends char = catMaybes $ liftA2 (<|>) getDroid getHuman <$> friends char++getEpisode :: Alternative f => Int -> f Text+getEpisode 4 = pure "NEWHOPE"+getEpisode 5 = pure "EMPIRE"+getEpisode 6 = pure "JEDI"+getEpisode _ = empty

@@ -0,0 +1,351 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+module Test.StarWars.QuerySpec+    ( spec+    ) where++import qualified Data.Aeson as Aeson+import Data.Aeson ( object+                  , (.=)+                  )+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.StarWars.Schema++-- * Test+-- See https://github.com/graphql/graphql-js/blob/master/src/__tests__/starWarsQueryTests.js++spec :: Spec+spec = describe "Star Wars Query Tests" $ do+    describe "Basic Queries" $ do+      it "R2-D2 hero" $ testQuery+        [r| query HeroNameQuery {+            hero {+                id+            }+            }+        |]+        $ object [ "data" .= object ["hero" .= object ["id" .= ("2001" :: Text)]]]+      it "R2-D2 ID and friends" $ testQuery+        [r| query HeroNameAndFriendsQuery {+            hero {+                id+                name+                friends {+                name+                }+            }+            }+        |]+        $ object [ "data" .= object [+            "hero" .= object+                [ "id" .= ("2001" :: Text)+                , r2d2Name+                , "friends" .=+                    [ object [lukeName]+                    , object [hanName]+                    , object [leiaName]+                    ]+                ]+        ]]++    describe "Nested Queries" $ do+      it "R2-D2 friends" $ testQuery+        [r| query NestedQuery {+              hero {+                name+                friends {+                  name+                  appearsIn+                    friends {+                      name+                    }+                }+              }+            }+        |]+        $ object [ "data" .= object [+          "hero" .= object [+              "name" .= ("R2-D2" :: Text)+            , "friends" .= [+                  object [+                      "name" .= ("Luke Skywalker" :: Text)+                    , "appearsIn" .= ["NEWHOPE","EMPIRE","JEDI" :: Text]+                    , "friends" .= [+                          object [hanName]+                        , object [leiaName]+                        , object [c3poName]+                        , object [r2d2Name]+                        ]+                    ]+                , object [+                      hanName+                    , "appearsIn" .= [ "NEWHOPE","EMPIRE","JEDI" :: Text]+                    , "friends" .= [+                          object [lukeName]+                        , object [leiaName]+                        , object [r2d2Name]+                        ]+                    ]+                , object [+                      leiaName+                    , "appearsIn" .= [ "NEWHOPE","EMPIRE","JEDI" :: Text]+                    , "friends" .= [+                          object [lukeName]+                        , object [hanName]+                        , object [c3poName]+                        , object [r2d2Name]+                        ]+                    ]+                ]+            ]+        ]]+      it "Luke ID" $ testQuery+        [r| query FetchLukeQuery {+              human(id: "1000") {+                name+              }+            }+        |]+        $ object [ "data" .= object [+          "human" .= object [lukeName]+        ]]++    it "Luke ID with variable" $ testQueryParams+      (\v -> if v == "someId" then Just "1000" else Nothing)+      [r| query FetchSomeIDQuery($someId: String!) {+            human(id: $someId) {+              name+            }+          }+      |]+      $ object [ "data" .= object [+        "human" .= object [lukeName]+      ]]+    it "Han ID with variable" $ testQueryParams+      (\v -> if v == "someId" then Just "1002" else Nothing)+      [r| query FetchSomeIDQuery($someId: String!) {+            human(id: $someId) {+              name+            }+          }+      |]+      $ object [ "data" .= object [+        "human" .= object [hanName]+      ]]+    it "Invalid ID" $ testQueryParams+      (\v -> if v == "id" then Just "Not a valid ID" else Nothing)+      [r| query humanQuery($id: String!) {+            human(id: $id) {+              name+            }+          }+      |] $ object ["data" .= object ["human" .= Aeson.Null]]+    it "Luke aliased" $ testQuery+      [r| query FetchLukeAliased {+            luke: human(id: "1000") {+              name+            }+          }+      |]+      $ object [ "data" .= object [+       "luke" .= object [lukeName]+      ]]+    it "R2-D2 ID and friends aliased" $ testQuery+      [r| query HeroNameAndFriendsQuery {+            hero {+              id+              name+              friends {+                friendName: name+              }+            }+          }+      |]+      $ object [ "data" .= object [+        "hero" .= object [+            "id" .= ("2001" :: Text)+          , r2d2Name+          , "friends" .= [+                object ["friendName" .= ("Luke Skywalker" :: Text)]+              , object ["friendName" .= ("Han Solo" :: Text)]+              , object ["friendName" .= ("Leia Organa" :: Text)]+              ]+          ]+      ]]+    it "Luke and Leia aliased" $ testQuery+      [r| query FetchLukeAndLeiaAliased {+            luke: human(id: "1000") {+              name+            }+            leia: human(id: "1003") {+              name+            }+          }+      |]+      $ object [ "data" .= object [+        "luke" .= object [lukeName]+      , "leia" .= object [leiaName]+      ]]++    describe "Fragments for complex queries" $ do+      it "Aliases to query for duplicate content" $ testQuery+        [r| query DuplicateFields {+              luke: human(id: "1000") {+                name+                homePlanet+              }+              leia: human(id: "1003") {+                name+                homePlanet+              }+            }+        |]+        $ object [ "data" .= object [+          "luke" .= object [lukeName, tatooine]+        , "leia" .= object [leiaName, alderaan]+        ]]+      it "Fragment for duplicate content" $ testQuery+        [r|  query UseFragment {+              luke: human(id: "1000") {+                ...HumanFragment+              }+              leia: human(id: "1003") {+                ...HumanFragment+              }+            }+            fragment HumanFragment on Human {+              name+              homePlanet+            }+        |]+        $ object [ "data" .= object [+          "luke" .= object [lukeName, tatooine]+        , "leia" .= object [leiaName, alderaan]+        ]]++    describe "__typename" $ do+      it "R2D2 is a Droid" $ testQuery+        [r| query CheckTypeOfR2 {+              hero {+                __typename+                name+              }+            }+          |]+        $ object ["data" .= object [+            "hero" .= object ["__typename" .= ("Droid" :: Text), r2d2Name]+        ]]+      it "Luke is a human" $ testQuery+        [r| query CheckTypeOfLuke {+              hero(episode: EMPIRE) {+                __typename+                name+              }+            }+          |]+        $ object ["data" .= object [+            "hero" .= object ["__typename" .= ("Human" :: Text), lukeName]+        ]]++    describe "Errors in resolvers" $ do+        it "error on secretBackstory" $ testQuery+          [r|+            query HeroNameQuery {+              hero {+                name+                  secretBackstory+              }+            }+          |]+          $ object+              [ "data" .= object+                  [ "hero" .= object+                      [ "name" .= ("R2-D2" :: Text)+                      , "secretBackstory" .= Aeson.Null+                      ]+                  ]+              , "errors" .=+                  [ object+                      ["message" .= ("secretBackstory is secret." :: Text)]+                  ]+              ]+        it "Error in a list" $ testQuery+          [r| query HeroNameQuery {+                hero {+                  name+                  friends {+                    name+                    secretBackstory+                  }+                }+              }+            |]+          $ object ["data" .= object+            [ "hero" .= object+                [ "name" .= ("R2-D2" :: Text)+                , "friends" .=+                    [ object+                        [ "name" .= ("Luke Skywalker" :: Text)+                        , "secretBackstory" .= Aeson.Null+                        ]+                    , object+                        [ "name" .= ("Han Solo" :: Text)+                        , "secretBackstory" .= Aeson.Null+                        ]+                    , object+                        [ "name" .= ("Leia Organa" :: Text)+                        , "secretBackstory" .= Aeson.Null+                        ]+                    ]+                ]+            ]+            , "errors" .=+                [ object ["message" .= ("secretBackstory is secret." :: Text)]+                , object ["message" .= ("secretBackstory is secret." :: Text)]+                , object ["message" .= ("secretBackstory is secret." :: Text)]+                ]+            ]+        it "error on secretBackstory with alias" $ testQuery+          [r| query HeroNameQuery {+                mainHero: hero {+                  name+                  story: secretBackstory+                }+              }+            |]+          $ object+              [ "data" .= object+                  [ "mainHero" .= object+                      [ "name" .= ("R2-D2" :: Text)+                      , "story" .= Aeson.Null+                      ]+                  ]+              , "errors" .=+                  [ object ["message" .= ("secretBackstory is secret." :: Text)]+                  ]+              ]++  where+    lukeName = "name" .= ("Luke Skywalker" :: Text)+    leiaName = "name" .= ("Leia Organa" :: Text)+    hanName = "name" .= ("Han Solo" :: Text)+    r2d2Name = "name" .= ("R2-D2" :: Text)+    c3poName = "name" .= ("C-3PO" :: Text)+    tatooine = "homePlanet" .= ("Tatooine" :: Text)+    alderaan = "homePlanet" .= ("Alderaan" :: Text)++testQuery :: Text -> Aeson.Value -> Expectation+testQuery q expected = graphql schema q >>= flip shouldBe expected++testQueryParams :: Subs -> Text -> Aeson.Value -> Expectation+testQueryParams f q expected = graphqlSubs schema f q >>= flip shouldBe expected

@@ -0,0 +1,63 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+module Test.StarWars.Schema+    ( character+    , droid+    , hero+    , human+    , schema+    ) where++import Control.Monad.Trans.Except (throwE)+import Control.Monad.Trans.Class (lift)+import Control.Monad.IO.Class (MonadIO(..))+import Data.List.NonEmpty (NonEmpty((:|)))+import Language.GraphQL.Schema ( Schema+                               , Resolver+                               , Argument(..)+                               , Value(..)+                               )+import qualified Language.GraphQL.Schema as Schema+import Language.GraphQL.Trans+import Language.GraphQL.Type+import Test.StarWars.Data++-- * Schema+-- See https://github.com/graphql/graphql-js/blob/master/src/__tests__/starWarsSchema.js++schema :: MonadIO m => Schema m+schema = hero :| [human, droid]++hero :: MonadIO m => Resolver m+hero = Schema.objectA "hero" $ \case+  [] -> character artoo+  [Argument "episode" (ValueEnum "NEWHOPE")] -> character $ getHero 4+  [Argument "episode" (ValueEnum "EMPIRE" )] -> character $ getHero 5+  [Argument "episode" (ValueEnum "JEDI"   )] -> character $ getHero 6+  _ -> ActionT $ throwE "Invalid arguments."++human :: MonadIO m => Resolver m+human = Schema.wrappedObjectA "human" $ \case+  [Argument "id" (ValueString i)] -> do+      humanCharacter <- lift $ return $ getHuman i >>= Just+      case humanCharacter of+        Nothing -> return Null+        Just e -> Named <$> character e+  _ -> ActionT $ throwE "Invalid arguments."++droid :: MonadIO m => Resolver m+droid = Schema.objectA "droid" $ \case+   [Argument "id" (ValueString i)] -> character =<< liftIO (getDroid i)+   _ -> ActionT $ throwE "Invalid arguments."++character :: MonadIO m => Character -> ActionT m [Resolver m]+character char = return+    [ Schema.scalar "id" $ return $ id_ char+    , Schema.scalar "name" $ return $ name char+    , Schema.wrappedObject "friends"+        $ traverse character $ List $ Named <$> getFriends char+    , Schema.enum "appearsIn" $ return $ foldMap getEpisode $ appearsIn char+    , Schema.scalar "secretBackstory" $ secretBackstory char+    , Schema.scalar "homePlanet" $ return $ either mempty homePlanet char+    , Schema.scalar "__typename" $ return $ typeName char+    ]

@@ -1,28 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE OverloadedStrings #-}-module Main where--#if !MIN_VERSION_base(4,8,0)-import Control.Applicative ((<$>), (<*>))-#endif--import Data.Attoparsec.Text (parseOnly)-import qualified Data.Text.IO as Text-import Test.Tasty (defaultMain)-import Test.Tasty.HUnit--import qualified Data.GraphQL.Parser as Parser-import qualified Data.GraphQL.Encoder as Encoder--import Paths_graphql (getDataFileName)--main :: IO ()-main = defaultMain =<< testCase "Kitchen Sink"-                   <$> (assertEqual "Encode" <$> expected <*> actual)-  where-    expected = Text.readFile-           =<< getDataFileName "tests/data/kitchen-sink.min.graphql"--    actual = either (error "Parsing error!") Encoder.document-         <$> parseOnly Parser.document-         <$> expected