graphql 0.7.0.0 → 0.8.0.0

raw patch · 31 files changed

+2189/−672 lines, 31 filesdep +scientificdep +vectorPVP ok

version bump matches the API change (PVP)

Dependencies added: scientific, vector

API changes (from Hackage documentation)

Files

• CHANGELOG.md +55/−3
• docs/tutorial/tutorial.lhs +40/−17
• graphql.cabal +17/−4
• src/Language/GraphQL.hs +11/−10
• src/Language/GraphQL/AST/Core.hs +3/−62
• src/Language/GraphQL/AST/Document.hs +35/−6
• src/Language/GraphQL/AST/Encoder.hs +82/−70
• src/Language/GraphQL/AST/Parser.hs +27/−21
• src/Language/GraphQL/Error.hs +26/−25
• src/Language/GraphQL/Execute.hs +36/−51
• src/Language/GraphQL/Execute/Coerce.hs +230/−0
• src/Language/GraphQL/Execute/Execution.hs +229/−0
• src/Language/GraphQL/Execute/Transform.hs +364/−95
• src/Language/GraphQL/Schema.hs +0/−138
• src/Language/GraphQL/Trans.hs +7/−4
• src/Language/GraphQL/Type.hs +13/−52
• src/Language/GraphQL/Type/Definition.hs +115/−0
• src/Language/GraphQL/Type/Directive.hs +8/−1
• src/Language/GraphQL/Type/In.hs +101/−0
• src/Language/GraphQL/Type/Out.hs +168/−0
• src/Language/GraphQL/Type/Schema.hs +112/−0
• tests/Language/GraphQL/AST/ParserSpec.hs +8/−1
• tests/Language/GraphQL/Execute/CoerceSpec.hs +122/−0
• tests/Language/GraphQL/ExecuteSpec.hs +75/−0
• tests/Language/GraphQL/Type/OutSpec.hs +14/−0
• tests/Test/DirectiveSpec.hs +22/−19
• tests/Test/FragmentSpec.hs +80/−37
• tests/Test/RootOperationSpec.hs +68/−0
• tests/Test/StarWars/Data.hs +10/−11
• tests/Test/StarWars/QuerySpec.hs +8/−9
• tests/Test/StarWars/Schema.hs +103/−36

@@ -6,8 +6,60 @@ and this project adheres to [Haskell Package Versioning Policy](https://pvp.haskell.org/). -## [Unreleased]+## [0.8.0.0] - 2020-06-20+### Fixed+- The parser rejects variables when parsing defaultValue (DefaultValue). The+  specification defines default values as `Value` with `const` parameter and+  constants cannot be variables. `AST.Document.ConstValue` was added,+  `AST.Document.ObjectField` was modified.+- AST transformation should never fail.+    * Arguments and fields with a missing variable as value should be left out.+    * Invalid (recusrive or non-existing) fragments should be skipped.+- Argument value coercion.+- Variable value coercion.+- Result coercion.+- The executor should skip the fields missing in the object type and not fail.+- Merging subselections. +### Changed+- `Schema.Resolver` was moved to `Type.Out`, it is a field and resolver function+  pair.+- `AST.Core.Value` was moved into `Type.Definition`. These values are used only+  in the execution and type system, it is not a part of the parsing tree.+- `Type` module is superseded by `Type.Out`. This module contains now only+  exports from other module that complete `Type.In` and `Type.Out` exports.+- `Error.CollectErrsT` contains the new `Resolution` data structure.+  `Resolution` represents the state used by the executor. It contains all types+  defined in the schema and collects the thrown errors.++### Added+- `Type.Definition` contains base type system definition, e.g. Enums and+  Scalars.+- `Type.Schema` describes a schema. Both public functions that execute queries+  accept a `Schema` now instead of a `HashMap`. The execution fails if the root+  operation doesn't match the root Query type in the schema.+- `Type.In` and `Type.Out` contain definitions for input and output types.+- `Execute.Coerce` defines a typeclass responsible for input, variable value+  coercion. It decouples us a bit from JSON since any format can be used to pass+  query variables. Execution functions accept (`HashMap Name a`) instead of+  `Subs`, where a is an instance of `VariableValue`.++### Removed+- `Schema.scalar`, `Schema.wrappedScalar`. They accepted everything can be+  converted to JSON and JSON is not suitable as an internal representation for+  GraphQL. E.g. GraphQL distinguishes between Floats and Integers.+- `Schema.wrappedObject`, `Schema.object`, `Schema.resolversToMap`. There is no+  need in special functions to construct field resolvers anymore, resolvers are+  normal functions attached to the fields in the schema representation.+- `Schema.resolve` is superseded by `Execute.Execution`.+- `Error.runAppendErrs` isn't used anywhere.+- `AST.Core`: `Document`, `Directive`, `Field`, `Fragment`, `Selection`, `Alias`+  `TypeCondition` were modified, moved into `Execute.Transform.Document` and+  made private. These types describe intermediate representation used by the+  executor internally. Moving was required to avoid cyclic dependencies between+  the executor and type system.+- `AST.Core` doesn't reexports anything.+ ## [0.7.0.0] - 2020-05-11 ### Fixed - Result of null encoding@@ -20,7 +72,7 @@ - `Trans.argument`. - Schema extension parser. - Contributing guidelines.-- `Schema.resolversToMap` (intended for to be used internally).+- `Schema.resolversToMap` (intended to be used internally).  ### Changed - Rename `AST.Definition` into `AST.Document.ExecutableDefinition`.@@ -215,7 +267,7 @@ ### Added - Data types for the GraphQL language. -[Unreleased]: https://github.com/caraus-ecms/graphql/compare/v0.6.1.0...HEAD+[0.8.0.0]: https://github.com/caraus-ecms/graphql/compare/v0.7.0.0...v0.8.0.0 [0.7.0.0]: https://github.com/caraus-ecms/graphql/compare/v0.6.1.0...v0.7.0.0 [0.6.1.0]: https://github.com/caraus-ecms/graphql/compare/v0.6.0.0...v0.6.1.0 [0.6.0.0]: https://github.com/caraus-ecms/graphql/compare/v0.5.1.0...v0.6.0.0

@@ -17,14 +17,15 @@ > import Control.Monad.IO.Class (liftIO) > import Data.Aeson (encode) > import Data.ByteString.Lazy.Char8 (putStrLn)-> import Data.HashMap.Strict (HashMap) > import qualified Data.HashMap.Strict as HashMap-> import Data.List.NonEmpty (NonEmpty(..)) > import Data.Text (Text)+> import qualified Data.Text as Text > import Data.Time (getCurrentTime) > > import Language.GraphQL-> import qualified Language.GraphQL.Schema as Schema+> import Language.GraphQL.Trans+> import Language.GraphQL.Type+> import qualified Language.GraphQL.Type.Out as Out > > import Prelude hiding (putStrLn) @@ -35,11 +36,19 @@  First we build a GraphQL schema. -> schema1 :: HashMap Text (NonEmpty (Schema.Resolver IO))-> schema1 = HashMap.singleton "Query" $ hello :| []+> schema1 :: Schema IO+> schema1 = Schema queryType Nothing >-> hello :: Schema.Resolver IO-> hello = Schema.scalar "hello" (return ("it's me" :: Text))+> queryType :: ObjectType IO+> queryType = ObjectType "Query" Nothing []+>   $ HashMap.singleton "hello"+>   $ Out.Resolver helloField hello+>+> helloField :: Field IO+> helloField = Field Nothing (Out.NamedScalarType string) mempty+>+> hello :: ActionT IO Value+> hello = pure $ String "it's me"  This defines a simple schema with one type and one field, that resolves to a fixed value. @@ -52,7 +61,7 @@ To run the query, we call the `graphql` with the schema and the query.  > main1 :: IO ()-> main1 = putStrLn =<< encode <$> graphql schema1 query1+> main1 = graphql schema1 query1 >>= putStrLn . encode  This runs the query by fetching the one field defined, returning@@ -65,13 +74,21 @@  For this example, we're going to be using time. -> schema2 :: HashMap Text (NonEmpty (Schema.Resolver IO))-> schema2 = HashMap.singleton "Query" $ time :| []+> schema2 :: Schema IO+> schema2 = Schema queryType2 Nothing >-> time :: Schema.Resolver IO-> time = Schema.scalar "time" $ do+> queryType2 :: ObjectType IO+> queryType2 = ObjectType "Query" Nothing []+>   $ HashMap.singleton "time"+>   $ Out.Resolver timeField time+>+> timeField :: Field IO+> timeField = Field Nothing (Out.NamedScalarType string) mempty+>+> time :: ActionT IO Value+> time = do >   t <- liftIO getCurrentTime->   return $ show t+>   pure $ String $ Text.pack $ show t  This defines a simple schema with one type and one field, which resolves to the current time.@@ -82,7 +99,7 @@ > query2 = "{ time }" > > main2 :: IO ()-> main2 = putStrLn =<< encode <$> graphql schema2 query2+> main2 = graphql schema2 query2 >>= putStrLn . encode  This runs the query, returning the current time @@ -124,14 +141,20 @@  Now that we have two resolvers, we can define a schema which uses them both. -> schema3 :: HashMap Text (NonEmpty (Schema.Resolver IO))-> schema3 = HashMap.singleton "Query" $ hello :| [time]+> schema3 :: Schema IO+> schema3 = Schema queryType3 Nothing >+> queryType3 :: ObjectType IO+> queryType3 = ObjectType "Query" Nothing [] $ HashMap.fromList+>   [ ("hello", Out.Resolver helloField hello)+>   , ("time", Out.Resolver timeField time)+>   ]+> > query3 :: Text > query3 = "query timeAndHello { time hello }" > > main3 :: IO ()-> main3 = putStrLn =<< encode <$> graphql schema3 query3+> main3 = graphql schema3 query3 >>= putStrLn . encode  This queries for both time and hello, returning 

@@ -1,6 +1,6 @@ cabal-version: 1.12 name: graphql-version: 0.7.0.0+version: 0.8.0.0 license: BSD3 license-file: LICENSE copyright: (c) 2019-2020 Eugen Wissner,@@ -41,13 +41,18 @@         Language.GraphQL.AST.Parser         Language.GraphQL.Error         Language.GraphQL.Execute-        Language.GraphQL.Schema+        Language.GraphQL.Execute.Coerce         Language.GraphQL.Trans         Language.GraphQL.Type+        Language.GraphQL.Type.In+        Language.GraphQL.Type.Out     hs-source-dirs: src     other-modules:+        Language.GraphQL.Execute.Execution         Language.GraphQL.Execute.Transform+        Language.GraphQL.Type.Definition         Language.GraphQL.Type.Directive+        Language.GraphQL.Type.Schema     default-language: Haskell2010     build-depends:         aeson >=1.4.7.1 && <1.5,@@ -55,9 +60,11 @@         containers >=0.6.2.1 && <0.7,         megaparsec >=8.0.0 && <8.1,         parser-combinators >=1.2.1 && <1.3,+        scientific >=0.3.6.2 && <0.4,         text >=1.2.4.0 && <1.3,         transformers >=0.5.6.2 && <0.6,-        unordered-containers >=0.2.10.0 && <0.3+        unordered-containers >=0.2.10.0 && <0.3,+        vector >=0.12.1.2 && <0.13  test-suite tasty     type: exitcode-stdio-1.0@@ -68,9 +75,13 @@         Language.GraphQL.AST.LexerSpec         Language.GraphQL.AST.ParserSpec         Language.GraphQL.ErrorSpec+        Language.GraphQL.Execute.CoerceSpec+        Language.GraphQL.ExecuteSpec+        Language.GraphQL.Type.OutSpec         Test.DirectiveSpec         Test.FragmentSpec         Test.KitchenSinkSpec+        Test.RootOperationSpec         Test.StarWars.Data         Test.StarWars.QuerySpec         Test.StarWars.Schema@@ -89,6 +100,8 @@         megaparsec >=8.0.0 && <8.1,         parser-combinators >=1.2.1 && <1.3,         raw-strings-qq ==1.1.*,+        scientific >=0.3.6.2 && <0.4,         text >=1.2.4.0 && <1.3,         transformers >=0.5.6.2 && <0.6,-        unordered-containers >=0.2.10.0 && <0.3+        unordered-containers >=0.2.10.0 && <0.3,+        vector >=0.12.1.2 && <0.13

@@ -5,29 +5,30 @@     ) where  import qualified Data.Aeson as Aeson-import Data.List.NonEmpty (NonEmpty) import Data.HashMap.Strict (HashMap) import Data.Text (Text)+import Language.GraphQL.AST.Document+import Language.GraphQL.AST.Parser import Language.GraphQL.Error import Language.GraphQL.Execute-import Language.GraphQL.AST.Parser-import qualified Language.GraphQL.Schema as Schema+import Language.GraphQL.Execute.Coerce+import Language.GraphQL.Type.Schema import Text.Megaparsec (parse)  -- | If the text parses correctly as a @GraphQL@ query the query is--- executed using the given 'Schema.Resolver's.+-- executed using the given 'Schema'. graphql :: Monad m-    => HashMap Text (NonEmpty (Schema.Resolver m)) -- ^ Resolvers.+    => Schema m -- ^ Resolvers.     -> Text -- ^ Text representing a @GraphQL@ request document.     -> m Aeson.Value -- ^ Response.-graphql = flip graphqlSubs mempty+graphql = flip graphqlSubs (mempty :: Aeson.Object)  -- | If the text parses correctly as a @GraphQL@ query the substitution is -- applied to the query and the query is then executed using to the given--- 'Schema.Resolver's.-graphqlSubs :: Monad m-    => HashMap Text (NonEmpty (Schema.Resolver m)) -- ^ Resolvers.-    -> Schema.Subs -- ^ Variable substitution function.+-- 'Schema'.+graphqlSubs :: (Monad m, VariableValue a)+    => Schema m -- ^ Resolvers.+    -> HashMap Name a -- ^ Variable substitution function.     -> Text -- ^ Text representing a @GraphQL@ request document.     -> m Aeson.Value -- ^ Response. graphqlSubs schema f

@@ -1,41 +1,11 @@ -- | This is the AST meant to be executed. module Language.GraphQL.AST.Core-    ( Alias-    , Arguments(..)-    , Directive(..)-    , Document-    , Field(..)-    , Fragment(..)-    , Name-    , Operation(..)-    , Selection(..)-    , TypeCondition-    , Value(..)+    ( Arguments(..)     ) where -import Data.Int (Int32) import Data.HashMap.Strict (HashMap)-import Data.List.NonEmpty (NonEmpty)-import Data.Sequence (Seq)-import Data.String (IsString(..))-import Data.Text (Text)-import Language.GraphQL.AST (Alias, Name, TypeCondition)---- | GraphQL document is a non-empty list of operations.-type Document = NonEmpty Operation---- | GraphQL has 3 operation types: queries, mutations and subscribtions.------ Currently only queries and mutations are supported.-data Operation-    = Query (Maybe Text) (Seq Selection)-    | Mutation (Maybe Text) (Seq Selection)-    deriving (Eq, Show)---- | Single GraphQL field.-data Field-    = Field (Maybe Alias) Name Arguments (Seq Selection)-    deriving (Eq, Show)+import Language.GraphQL.AST (Name)+import Language.GraphQL.Type.Definition  -- | Argument list. newtype Arguments = Arguments (HashMap Name Value)@@ -47,32 +17,3 @@ instance Monoid Arguments where     mempty = Arguments mempty --- | Directive.-data Directive = Directive Name Arguments-    deriving (Eq, Show)---- | Represents fragments and inline fragments.-data Fragment-    = Fragment TypeCondition (Seq Selection)-    deriving (Eq, Show)---- | Single selection element.-data Selection-    = SelectionFragment Fragment-    | SelectionField Field-    deriving (Eq, Show)---- | Represents accordingly typed GraphQL values.-data Value-    = Int Int32-    | Float Double -- ^ GraphQL Float is double precision-    | String Text-    | Boolean Bool-    | Null-    | Enum Name-    | List [Value]-    | Object (HashMap Name Value)-    deriving (Eq, Show)--instance IsString Value where-    fromString = String . fromString

@@ -8,6 +8,7 @@     ( Alias     , Argument(..)     , ArgumentsDefinition(..)+    , ConstValue(..)     , Definition(..)     , Description(..)     , Directive(..)@@ -197,7 +198,7 @@  -- ** Input Values --- | Input value.+-- | Input value (literal or variable). data Value     = Variable Name     | Int Int32@@ -207,18 +208,46 @@     | Null     | Enum Name     | List [Value]-    | Object [ObjectField]+    | Object [ObjectField Value]     deriving (Eq, Show) +-- | Constant input value.+data ConstValue+    = ConstInt Int32+    | ConstFloat Double+    | ConstString Text+    | ConstBoolean Bool+    | ConstNull+    | ConstEnum Name+    | ConstList [ConstValue]+    | ConstObject [ObjectField ConstValue]+    deriving (Eq, Show)+ -- | Key-value pair. -----   A list of 'ObjectField's represents a GraphQL object type.-data ObjectField = ObjectField Name Value deriving (Eq, Show)+-- A list of 'ObjectField's represents a GraphQL object type.+data ObjectField a = ObjectField Name a+    deriving (Eq, Show)  -- ** Variables  -- | Variable definition.-data VariableDefinition = VariableDefinition Name Type (Maybe Value)+--+-- Each operation can include a list of variables:+--+-- @+-- query (protagonist: String = "Zarathustra") {+--   getAuthor(protagonist: $protagonist)+-- }+-- @+--+-- This query defines an optional variable @protagonist@ of type @String@,+-- its default value is "Zarathustra". If no default value is defined and no+-- value is provided, a variable can still be @null@ if its type is nullable.+--+-- Variables are usually passed along with the query, but not in the query+-- itself. They make queries reusable.+data VariableDefinition = VariableDefinition Name Type (Maybe ConstValue)     deriving (Eq, Show)  -- ** Type References@@ -445,7 +474,7 @@ -- -- The input type "Point2D" contains two value definitions: "x" and "y". data InputValueDefinition-    = InputValueDefinition Description Name Type (Maybe Value) [Directive]+    = InputValueDefinition Description Name Type (Maybe ConstValue) [Directive]     deriving (Eq, Show)  -- ** Unions

@@ -24,7 +24,6 @@ import qualified Data.Text.Lazy.Builder as Builder import Data.Text.Lazy.Builder.Int (decimal, hexadecimal) import Data.Text.Lazy.Builder.RealFloat (realFloat)-import qualified Language.GraphQL.AST as Full import Language.GraphQL.AST.Document  -- | Instructs the encoder whether the GraphQL document should be minified or@@ -53,32 +52,32 @@     executableDefinition (ExecutableDefinition x) acc = definition formatter x : acc     executableDefinition _ acc = acc --- | Converts a t'Full.ExecutableDefinition' into a string.+-- | Converts a t'ExecutableDefinition' into a string. definition :: Formatter -> ExecutableDefinition -> Lazy.Text definition formatter x     | Pretty _ <- formatter = Lazy.Text.snoc (encodeDefinition x) '\n'     | Minified <- formatter = encodeDefinition x   where-    encodeDefinition (Full.DefinitionOperation operation)+    encodeDefinition (DefinitionOperation operation)         = operationDefinition formatter operation-    encodeDefinition (Full.DefinitionFragment fragment)+    encodeDefinition (DefinitionFragment fragment)         = fragmentDefinition formatter fragment --- | Converts a 'Full.OperationDefinition into a string.-operationDefinition :: Formatter -> Full.OperationDefinition -> Lazy.Text-operationDefinition formatter (Full.SelectionSet sels)+-- | Converts a 'OperationDefinition into a string.+operationDefinition :: Formatter -> OperationDefinition -> Lazy.Text+operationDefinition formatter (SelectionSet sels)     = selectionSet formatter sels-operationDefinition formatter (Full.OperationDefinition Full.Query name vars dirs sels)+operationDefinition formatter (OperationDefinition Query name vars dirs sels)     = "query " <> node formatter name vars dirs sels-operationDefinition formatter (Full.OperationDefinition Full.Mutation name vars dirs sels)+operationDefinition formatter (OperationDefinition Mutation name vars dirs sels)     = "mutation " <> node formatter name vars dirs sels --- | Converts a Full.Query or Full.Mutation into a string.+-- | Converts a Query or Mutation into a string. node :: Formatter ->-    Maybe Full.Name ->-    [Full.VariableDefinition] ->-    [Full.Directive] ->-    Full.SelectionSet ->+    Maybe Name ->+    [VariableDefinition] ->+    [Directive] ->+    SelectionSet ->     Lazy.Text node formatter name vars dirs sels     = Lazy.Text.fromStrict (fold name)@@ -87,31 +86,31 @@     <> eitherFormat formatter " " mempty     <> selectionSet formatter sels -variableDefinitions :: Formatter -> [Full.VariableDefinition] -> Lazy.Text+variableDefinitions :: Formatter -> [VariableDefinition] -> Lazy.Text variableDefinitions formatter     = parensCommas formatter $ variableDefinition formatter -variableDefinition :: Formatter -> Full.VariableDefinition -> Lazy.Text-variableDefinition formatter (Full.VariableDefinition var ty dv)+variableDefinition :: Formatter -> VariableDefinition -> Lazy.Text+variableDefinition formatter (VariableDefinition var ty defaultValue')     = variable var     <> eitherFormat formatter ": " ":"     <> type' ty-    <> maybe mempty (defaultValue formatter) dv+    <> maybe mempty (defaultValue formatter) defaultValue' -defaultValue :: Formatter -> Full.Value -> Lazy.Text+defaultValue :: Formatter -> ConstValue -> Lazy.Text defaultValue formatter val     = eitherFormat formatter " = " "="-    <> value formatter val+    <> value formatter (fromConstValue val) -variable :: Full.Name -> Lazy.Text+variable :: Name -> Lazy.Text variable var = "$" <> Lazy.Text.fromStrict var -selectionSet :: Formatter -> Full.SelectionSet -> Lazy.Text+selectionSet :: Formatter -> SelectionSet -> Lazy.Text selectionSet formatter     = bracesList formatter (selection formatter)     . NonEmpty.toList -selectionSetOpt :: Formatter -> Full.SelectionSetOpt -> Lazy.Text+selectionSetOpt :: Formatter -> SelectionSetOpt -> Lazy.Text selectionSetOpt formatter = bracesList formatter $ selection formatter  indentSymbol :: Lazy.Text@@ -120,14 +119,14 @@ indent :: (Integral a) => a -> Lazy.Text indent indentation = Lazy.Text.replicate (fromIntegral indentation) indentSymbol -selection :: Formatter -> Full.Selection -> Lazy.Text+selection :: Formatter -> Selection -> Lazy.Text selection formatter = Lazy.Text.append indent' . encodeSelection   where-    encodeSelection (Full.Field alias name args directives' selections) =+    encodeSelection (Field alias name args directives' selections) =         field incrementIndent alias name args directives' selections-    encodeSelection (Full.InlineFragment typeCondition directives' selections) =+    encodeSelection (InlineFragment typeCondition directives' selections) =         inlineFragment incrementIndent typeCondition directives' selections-    encodeSelection (Full.FragmentSpread name directives') =+    encodeSelection (FragmentSpread name directives') =         fragmentSpread incrementIndent name directives'     incrementIndent         | Pretty indentation <- formatter = Pretty $ indentation + 1@@ -139,13 +138,13 @@ colon :: Formatter -> Lazy.Text colon formatter = eitherFormat formatter ": " ":" --- | Converts Full.Field into a string+-- | Converts Field into a string field :: Formatter ->-    Maybe Full.Name ->-    Full.Name ->-    [Full.Argument] ->-    [Full.Directive] ->-    [Full.Selection] ->+    Maybe Name ->+    Name ->+    [Argument] ->+    [Directive] ->+    [Selection] ->     Lazy.Text field formatter alias name args dirs set     = optempty prependAlias (fold alias)@@ -158,27 +157,27 @@     selectionSetOpt' = (eitherFormat formatter " " "" <>)         . selectionSetOpt formatter -arguments :: Formatter -> [Full.Argument] -> Lazy.Text+arguments :: Formatter -> [Argument] -> Lazy.Text arguments formatter = parensCommas formatter $ argument formatter -argument :: Formatter -> Full.Argument -> Lazy.Text-argument formatter (Full.Argument name value')+argument :: Formatter -> Argument -> Lazy.Text+argument formatter (Argument name value')     = Lazy.Text.fromStrict name     <> colon formatter     <> value formatter value'  -- * Fragments -fragmentSpread :: Formatter -> Full.Name -> [Full.Directive] -> Lazy.Text+fragmentSpread :: Formatter -> Name -> [Directive] -> Lazy.Text fragmentSpread formatter name directives'     = "..." <> Lazy.Text.fromStrict name     <> optempty (directives formatter) directives'  inlineFragment ::     Formatter ->-    Maybe Full.TypeCondition ->-    [Full.Directive] ->-    Full.SelectionSet ->+    Maybe TypeCondition ->+    [Directive] ->+    SelectionSet ->     Lazy.Text inlineFragment formatter tc dirs sels = "... on "     <> Lazy.Text.fromStrict (fold tc)@@ -186,8 +185,8 @@     <> eitherFormat formatter " " mempty     <> selectionSet formatter sels -fragmentDefinition :: Formatter -> Full.FragmentDefinition -> Lazy.Text-fragmentDefinition formatter (Full.FragmentDefinition name tc dirs sels)+fragmentDefinition :: Formatter -> FragmentDefinition -> Lazy.Text+fragmentDefinition formatter (FragmentDefinition name tc dirs sels)     = "fragment " <> Lazy.Text.fromStrict name     <> " on " <> Lazy.Text.fromStrict tc     <> optempty (directives formatter) dirs@@ -196,27 +195,40 @@  -- * Miscellaneous --- | Converts a 'Full.Directive' into a string.-directive :: Formatter -> Full.Directive -> Lazy.Text-directive formatter (Full.Directive name args)+-- | Converts a 'Directive' into a string.+directive :: Formatter -> Directive -> Lazy.Text+directive formatter (Directive name args)     = "@" <> Lazy.Text.fromStrict name <> optempty (arguments formatter) args -directives :: Formatter -> [Full.Directive] -> Lazy.Text+directives :: Formatter -> [Directive] -> Lazy.Text directives Minified = spaces (directive Minified) directives formatter = Lazy.Text.cons ' ' . spaces (directive formatter) --- | Converts a 'Full.Value' into a string.-value :: Formatter -> Full.Value -> Lazy.Text-value _ (Full.Variable x) = variable x-value _ (Full.Int x) = Builder.toLazyText $ decimal x-value _ (Full.Float x) = Builder.toLazyText $ realFloat x-value _ (Full.Boolean  x) = booleanValue x-value _ Full.Null = "null"-value formatter (Full.String string) = stringValue formatter string-value _ (Full.Enum x) = Lazy.Text.fromStrict x-value formatter (Full.List x) = listValue formatter x-value formatter (Full.Object x) = objectValue formatter x+-- | Converts a 'Value' into a string.+value :: Formatter -> Value -> Lazy.Text+value _ (Variable x) = variable x+value _ (Int x) = Builder.toLazyText $ decimal x+value _ (Float x) = Builder.toLazyText $ realFloat x+value _ (Boolean  x) = booleanValue x+value _ Null = "null"+value formatter (String string) = stringValue formatter string+value _ (Enum x) = Lazy.Text.fromStrict x+value formatter (List x) = listValue formatter x+value formatter (Object x) = objectValue formatter x +fromConstValue :: ConstValue -> Value+fromConstValue (ConstInt x) = Int x+fromConstValue (ConstFloat x) = Float x+fromConstValue (ConstBoolean  x) = Boolean x+fromConstValue ConstNull = Null+fromConstValue (ConstString string) = String string+fromConstValue (ConstEnum x) = Enum x+fromConstValue (ConstList x) = List $ fromConstValue <$> x+fromConstValue (ConstObject x) = Object $ fromConstObjectField <$> x+  where+    fromConstObjectField (ObjectField key value') =+        ObjectField key $ fromConstValue value'+ booleanValue :: Bool -> Lazy.Text booleanValue True  = "true" booleanValue False = "false"@@ -271,10 +283,10 @@   where     unicode prefix = mappend (Builder.fromString prefix) . (hexadecimal . ord) -listValue :: Formatter -> [Full.Value] -> Lazy.Text+listValue :: Formatter -> [Value] -> Lazy.Text listValue formatter = bracketsCommas formatter $ value formatter -objectValue :: Formatter -> [Full.ObjectField] -> Lazy.Text+objectValue :: Formatter -> [ObjectField Value] -> Lazy.Text objectValue formatter = intercalate $ objectField formatter   where     intercalate f@@ -282,22 +294,22 @@         . Lazy.Text.intercalate (eitherFormat formatter ", " ",")         . fmap f -objectField :: Formatter -> Full.ObjectField -> Lazy.Text-objectField formatter (Full.ObjectField name value') =+objectField :: Formatter -> ObjectField Value -> Lazy.Text+objectField formatter (ObjectField name value') =     Lazy.Text.fromStrict name <> colon formatter <> value formatter value' --- | Converts a 'Full.Type' a type into a string.-type' :: Full.Type -> Lazy.Text-type' (Full.TypeNamed   x) = Lazy.Text.fromStrict x-type' (Full.TypeList    x) = listType x-type' (Full.TypeNonNull x) = nonNullType x+-- | Converts a 'Type' a type into a string.+type' :: Type -> Lazy.Text+type' (TypeNamed   x) = Lazy.Text.fromStrict x+type' (TypeList    x) = listType x+type' (TypeNonNull x) = nonNullType x -listType :: Full.Type -> Lazy.Text+listType :: Type -> Lazy.Text listType x = brackets (type' x) -nonNullType :: Full.NonNullType -> Lazy.Text-nonNullType (Full.NonNullTypeNamed x) = Lazy.Text.fromStrict x <> "!"-nonNullType (Full.NonNullTypeList  x) = listType x <> "!"+nonNullType :: NonNullType -> Lazy.Text+nonNullType (NonNullTypeNamed x) = Lazy.Text.fromStrict x <> "!"+nonNullType (NonNullTypeList  x) = listType x <> "!"  -- * Internal 

@@ -403,32 +403,38 @@  value :: Parser Value value = Variable <$> variable-    <|> Float    <$> try float-    <|> Int      <$> integer-    <|> Boolean  <$> booleanValue-    <|> Null     <$  symbol "null"-    <|> String   <$> blockString-    <|> String   <$> string-    <|> Enum     <$> try enumValue-    <|> List     <$> listValue-    <|> Object   <$> objectValue+    <|> Float <$> try float+    <|> Int <$> integer+    <|> Boolean <$> booleanValue+    <|> Null <$  symbol "null"+    <|> String <$> blockString+    <|> String <$> string+    <|> Enum <$> try enumValue+    <|> List <$> brackets (some value)+    <|> Object <$> braces (some $ objectField value)     <?> "value error!"-  where-    booleanValue :: Parser Bool-    booleanValue = True  <$ symbol "true"-               <|> False <$ symbol "false" -    listValue :: Parser [Value]-    listValue = brackets $ some value+constValue :: Parser ConstValue+constValue = ConstFloat <$> try float+    <|> ConstInt <$> integer+    <|> ConstBoolean <$> booleanValue+    <|> ConstNull <$  symbol "null"+    <|> ConstString <$> blockString+    <|> ConstString <$> string+    <|> ConstEnum <$> try enumValue+    <|> ConstList <$> brackets (some constValue)+    <|> ConstObject <$> braces (some $ objectField constValue)+    <?> "value error!" -    objectValue :: Parser [ObjectField]-    objectValue = braces $ some objectField+booleanValue :: Parser Bool+booleanValue = True  <$ symbol "true"+    <|> False <$ symbol "false"  enumValue :: Parser Name enumValue = but (symbol "true") *> but (symbol "false") *> but (symbol "null") *> name -objectField :: Parser ObjectField-objectField = ObjectField <$> name <* colon <*> value+objectField :: Parser a -> Parser (ObjectField a)+objectField valueParser = ObjectField <$> name <* colon <*> valueParser  -- * Variables @@ -446,8 +452,8 @@ variable :: Parser Name variable = dollar *> name -defaultValue :: Parser (Maybe Value)-defaultValue = optional (equals *> value) <?> "DefaultValue"+defaultValue :: Parser (Maybe ConstValue)+defaultValue = optional (equals *> constValue) <?> "DefaultValue"  -- * Input Types 

@@ -5,21 +5,20 @@ module Language.GraphQL.Error     ( parseError     , CollectErrsT+    , Resolution(..)     , addErr     , addErrMsg     , runCollectErrs-    , runAppendErrs     , singleError     ) where +import Control.Monad.Trans.State (StateT, modify, runStateT) import qualified Data.Aeson as Aeson+import Data.HashMap.Strict (HashMap) import Data.Text (Text) import Data.Void (Void)-import Control.Monad.Trans.Class (lift)-import Control.Monad.Trans.State ( StateT-                                 , modify-                                 , runStateT-                                 )+import Language.GraphQL.AST.Document (Name)+import Language.GraphQL.Type.Schema import Text.Megaparsec     ( ParseErrorBundle(..)     , PosState(..)@@ -30,6 +29,12 @@     , unPos     ) +-- | Executor context.+data Resolution m = Resolution+    { errors :: [Aeson.Value]+    , types :: HashMap Name (Type m)+    }+ -- | Wraps a parse error into a list of errors. parseError :: Applicative f => ParseErrorBundle Text Void -> f Aeson.Value parseError ParseErrorBundle{..}  =@@ -46,11 +51,13 @@          in (errorObject x sourcePosition : result, newState)  -- | A wrapper to pass error messages around.-type CollectErrsT m = StateT [Aeson.Value] m+type CollectErrsT m = StateT (Resolution m) m  -- | Adds an error to the list of errors. addErr :: Monad m => Aeson.Value -> CollectErrsT m ()-addErr v = modify (v :)+addErr v = modify appender+  where+    appender resolution@Resolution{..} = resolution{ errors = v : errors }  makeErrorMessage :: Text -> Aeson.Value makeErrorMessage s = Aeson.object [("message", Aeson.toJSON s)]@@ -66,23 +73,17 @@ 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+runCollectErrs :: Monad m+    => HashMap Name (Type m)+    -> CollectErrsT m Aeson.Value+    -> m Aeson.Value+runCollectErrs types' res = do+    (dat, Resolution{..}) <- runStateT res $ Resolution{ errors = [], types = types' }+    if null errors        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+       else return $ Aeson.object+           [ ("data", dat)+           , ("errors", Aeson.toJSON $ reverse errors)+           ]

@@ -1,5 +1,3 @@-{-# LANGUAGE OverloadedStrings #-}- -- | This module provides functions to execute a @GraphQL@ request. module Language.GraphQL.Execute     ( execute@@ -7,33 +5,30 @@     ) where  import qualified Data.Aeson as Aeson-import Data.List.NonEmpty (NonEmpty(..))-import qualified Data.List.NonEmpty as NonEmpty import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap+import Data.Sequence (Seq(..)) import Data.Text (Text)-import qualified Data.Text as Text-import Language.GraphQL.AST.Document-import qualified Language.GraphQL.AST.Core as AST.Core+import Language.GraphQL.AST.Document (Document, Name)+import Language.GraphQL.Execute.Coerce+import Language.GraphQL.Execute.Execution import qualified Language.GraphQL.Execute.Transform as Transform import Language.GraphQL.Error-import qualified Language.GraphQL.Schema as Schema+import qualified Language.GraphQL.Type.Definition as Definition+import qualified Language.GraphQL.Type.Out as Out+import Language.GraphQL.Type.Schema  -- | The substitution is applied to the document, and the 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 :: Monad m-    => HashMap Text (NonEmpty (Schema.Resolver m)) -- ^ Resolvers.-    -> Schema.Subs -- ^ Variable substitution function.+execute :: (Monad m, VariableValue a)+    => Schema m -- ^ Resolvers.+    -> HashMap.HashMap Name a -- ^ Variable substitution function.     -> Document -- @GraphQL@ document.     -> m Aeson.Value-execute schema subs doc =-    maybe transformError (document schema Nothing)-        $ Transform.document subs doc-  where-    transformError = return $ singleError "Schema transformation error."+execute schema = executeRequest schema Nothing  -- | The substitution is applied to the document, and the resolvers are applied -- to the resulting fields. The operation name can be used if the document@@ -41,46 +36,36 @@ -- -- Returns the result of the query against the schema wrapped in a /data/ -- field, or errors wrapped in an /errors/ field.-executeWithName :: Monad m-    => HashMap Text (NonEmpty (Schema.Resolver m)) -- ^ Resolvers+executeWithName :: (Monad m, VariableValue a)+    => Schema m -- ^ Resolvers     -> Text -- ^ Operation name.-    -> Schema.Subs -- ^ Variable substitution function.+    -> HashMap.HashMap Name a -- ^ Variable substitution function.     -> Document -- ^ @GraphQL@ Document.     -> m Aeson.Value-executeWithName schema name subs doc =-    maybe transformError (document schema $ Just name)-        $ Transform.document subs doc-  where-    transformError = return $ singleError "Schema transformation error."+executeWithName schema operationName =+    executeRequest schema (Just operationName) -document :: Monad m-    => HashMap Text (NonEmpty (Schema.Resolver m))+executeRequest :: (Monad m, VariableValue a)+    => Schema m     -> Maybe Text-    -> AST.Core.Document+    -> HashMap.HashMap Name a+    -> Document     -> m Aeson.Value-document schema Nothing (op :| []) = operation schema op-document schema (Just name) operations = case NonEmpty.dropWhile matchingName operations of-    [] -> return $ singleError-        $ Text.unwords ["Operation", name, "couldn't be found in the document."]-    (op:_)  -> operation schema op-  where-    matchingName (AST.Core.Query (Just name') _) = name == name'-    matchingName (AST.Core.Mutation (Just name') _) = name == name'-    matchingName _ = False-document _ _ _ = return $ singleError "Missing operation name."+executeRequest schema operationName subs document =+    case Transform.document schema operationName subs document of+        Left queryError -> pure $ singleError $ Transform.queryError queryError+        Right (Transform.Document types' rootObjectType operation)+          | (Transform.Query _ fields) <- operation ->+              executeOperation types' rootObjectType fields+          | (Transform.Mutation _ fields) <- operation ->+              executeOperation types' rootObjectType fields -operation :: Monad m-    => HashMap Text (NonEmpty (Schema.Resolver m))-    -> AST.Core.Operation+-- This is actually executeMutation, but we don't distinguish between queries+-- and mutations yet.+executeOperation :: Monad m+    => HashMap Name (Type m)+    -> Out.ObjectType m+    -> Seq (Transform.Selection m)     -> m Aeson.Value-operation schema = schemaOperation-  where-    runResolver fields = runCollectErrs-        . flip Schema.resolve fields-        . Schema.resolversToMap-    resolve fields queryType = maybe lookupError (runResolver fields)-        $ HashMap.lookup queryType schema-    lookupError = pure-        $ singleError "Root operation type couldn't be found in the schema."-    schemaOperation (AST.Core.Query _ fields) = resolve fields "Query"-    schemaOperation (AST.Core.Mutation _ fields) = resolve fields "Mutation"+executeOperation types' objectType fields =+    runCollectErrs types' $ executeSelectionSet Definition.Null objectType fields

@@ -0,0 +1,230 @@+{-# LANGUAGE ExplicitForAll #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ViewPatterns #-}++-- | Types and functions used for input and result coercion.+module Language.GraphQL.Execute.Coerce+    ( Output(..)+    , Serialize(..)+    , VariableValue(..)+    , coerceInputLiteral+    , matchFieldValues+    ) where++import qualified Data.Aeson as Aeson+import Data.Int (Int32)+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HashMap+import Data.Map.Strict (Map)+import Data.String (IsString(..))+import Data.Text (Text)+import qualified Data.Text.Lazy as Text.Lazy+import qualified Data.Text.Lazy.Builder as Text.Builder+import qualified Data.Text.Lazy.Builder.Int as Text.Builder+import Data.Scientific (toBoundedInteger, toRealFloat)+import Language.GraphQL.AST (Name)+import qualified Language.GraphQL.Type as Type+import qualified Language.GraphQL.Type.In as In+import qualified Language.GraphQL.Type.Out as Out++-- | Since variables are passed separately from the query, in an independent+-- format, they should be first coerced to the internal representation used by+-- this implementation.+class VariableValue a where+    -- | Only a basic, format-specific, coercion must be done here. Type+    -- correctness or nullability shouldn't be validated here, they will be+    -- validated later. The type information is provided only as a hint.+    --+    -- For example @GraphQL@ prohibits the coercion from a 't:Float' to an+    -- 't:Int', but @JSON@ doesn't have integers, so whole numbers should be+    -- coerced to 't:Int` when receiving variables as a JSON object. The same+    -- holds for 't:Enum'. There are formats that support enumerations, @JSON@+    -- doesn't, so the type information is given and 'coerceVariableValue' can+    -- check that an 't:Enum' is expected and treat the given value+    -- appropriately. Even checking whether this value is a proper member of the+    -- corresponding 't:Enum' type isn't required here, since this can be+    -- checked independently.+    --+    -- Another example is an @ID@. @GraphQL@ explicitly allows to coerce+    -- integers and strings to @ID@s, so if an @ID@ is received as an integer,+    -- it can be left as is and will be coerced later.+    --+    -- If a value cannot be coerced without losing information, 'Nothing' should+    -- be returned, the coercion will fail then and the query won't be executed.+    coerceVariableValue+        :: In.Type -- ^ Expected type (variable type given in the query).+        -> a -- ^ Variable value being coerced.+        -> Maybe Type.Value -- ^ Coerced value on success, 'Nothing' otherwise.++instance VariableValue Aeson.Value where+    coerceVariableValue _ Aeson.Null = Just Type.Null+    coerceVariableValue (In.ScalarBaseType scalarType) value+        | (Aeson.String stringValue) <- value = Just $ Type.String stringValue+        | (Aeson.Bool booleanValue) <- value = Just $ Type.Boolean booleanValue+        | (Aeson.Number numberValue) <- value+        , (Type.ScalarType "Float" _) <- scalarType =+            Just $ Type.Float $ toRealFloat numberValue+        | (Aeson.Number numberValue) <- value = -- ID or Int+            Type.Int <$> toBoundedInteger numberValue+    coerceVariableValue (In.EnumBaseType _) (Aeson.String stringValue) =+        Just $ Type.Enum stringValue+    coerceVariableValue (In.InputObjectBaseType objectType) value+        | (Aeson.Object objectValue) <- value = do+            let (In.InputObjectType _ _ inputFields) = objectType+            (newObjectValue, resultMap) <- foldWithKey objectValue inputFields+            if HashMap.null newObjectValue+                then Just $ Type.Object resultMap+                else Nothing+      where+        foldWithKey objectValue = HashMap.foldrWithKey matchFieldValues'+            $ Just (objectValue, HashMap.empty)+        matchFieldValues' _ _ Nothing = Nothing+        matchFieldValues' fieldName inputField (Just (objectValue, resultMap)) =+            let (In.InputField _ fieldType _) = inputField+                insert = flip (HashMap.insert fieldName) resultMap+                newObjectValue = HashMap.delete fieldName objectValue+             in case HashMap.lookup fieldName objectValue of+                    Just variableValue -> do+                        coerced <- coerceVariableValue fieldType variableValue+                        pure (newObjectValue, insert coerced)+                    Nothing -> Just (objectValue, resultMap)+    coerceVariableValue (In.ListBaseType listType) value+        | (Aeson.Array arrayValue) <- value =+            Type.List <$> foldr foldVector (Just []) arrayValue+        | otherwise = coerceVariableValue listType value+      where+        foldVector _ Nothing = Nothing+        foldVector variableValue (Just list) = do+            coerced <- coerceVariableValue listType variableValue+            pure $ coerced : list +    coerceVariableValue _ _ = Nothing++-- | Looks up a value by name in the given map, coerces it and inserts into the+-- result map. If the coercion fails, returns 'Nothing'. If the value isn't+-- given, but a default value is known, inserts the default value into the+-- result map. Otherwise it fails with 'Nothing' if the Input Type is a+-- Non-Nullable type, or returns the unchanged, original map.+matchFieldValues :: forall a+    . (In.Type -> a -> Maybe Type.Value)+    -> HashMap Name a+    -> Name+    -> In.Type+    -> Maybe Type.Value+    -> Maybe (HashMap Name Type.Value)+    -> Maybe (HashMap Name Type.Value)+matchFieldValues coerce values' fieldName type' defaultValue resultMap =+    case HashMap.lookup fieldName values' of+        Just variableValue -> coerceRuntimeValue $ coerce type' variableValue+        Nothing+            | Just value <- defaultValue ->+                HashMap.insert fieldName value <$> resultMap+            | Nothing <- defaultValue+            , In.isNonNullType type' -> Nothing+            | otherwise -> resultMap+  where+    coerceRuntimeValue (Just Type.Null)+        | In.isNonNullType type' = Nothing+    coerceRuntimeValue coercedValue =+        HashMap.insert fieldName <$> coercedValue <*> resultMap++-- | Coerces operation arguments according to the input coercion rules for the+-- corresponding types.+coerceInputLiteral :: In.Type -> Type.Value -> Maybe Type.Value+coerceInputLiteral (In.isNonNullType -> False) Type.Null = Just Type.Null+coerceInputLiteral (In.ScalarBaseType type') value+    | (Type.String stringValue) <- value+    , (Type.ScalarType "String" _) <- type' = Just $ Type.String stringValue+    | (Type.Boolean booleanValue) <- value+    , (Type.ScalarType "Boolean" _) <- type' = Just $ Type.Boolean booleanValue+    | (Type.Int intValue) <- value+    , (Type.ScalarType "Int" _) <- type' = Just $ Type.Int intValue+    | (Type.Float floatValue) <- value+    , (Type.ScalarType "Float" _) <- type' = Just $ Type.Float floatValue+    | (Type.Int intValue) <- value+    , (Type.ScalarType "Float" _) <- type' =+        Just $ Type.Float $ fromIntegral intValue+    | (Type.String stringValue) <- value+    , (Type.ScalarType "ID" _) <- type' = Just $ Type.String stringValue+    | (Type.Int intValue) <- value+    , (Type.ScalarType "ID" _) <- type' = Just $ decimal intValue+  where+    decimal = Type.String+        . Text.Lazy.toStrict+        . Text.Builder.toLazyText+        . Text.Builder.decimal+coerceInputLiteral (In.EnumBaseType type') (Type.Enum enumValue)+    | member enumValue type' = Just $ Type.Enum enumValue+  where+    member value (Type.EnumType _ _ members) = HashMap.member value members+coerceInputLiteral (In.InputObjectBaseType type') (Type.Object values) = +    let (In.InputObjectType _ _ inputFields) = type'+     in Type.Object+            <$> HashMap.foldrWithKey (matchFieldValues' values) (Just HashMap.empty) inputFields+  where+    matchFieldValues' values' fieldName (In.InputField _ inputFieldType defaultValue) =+        matchFieldValues coerceInputLiteral values' fieldName inputFieldType defaultValue+coerceInputLiteral (In.ListBaseType listType) (Type.List list) =+    Type.List <$> traverse (coerceInputLiteral listType) list+coerceInputLiteral (In.ListBaseType listType) singleton =+    wrapSingleton listType singleton+  where+      wrapSingleton (In.ListBaseType listType') singleton' =+          Type.List <$> sequence [wrapSingleton listType' singleton']+      wrapSingleton listType' singleton' =+          Type.List <$> sequence [coerceInputLiteral listType' singleton']+coerceInputLiteral _ _ = Nothing++-- | 'Serialize' describes how a @GraphQL@ value should be serialized.+class Serialize a where+    -- | Serializes a @GraphQL@ value according to the given serialization+    -- format.+    --+    -- Type infomration is given as a hint, e.g. if you need to know what type+    -- is being serialized to serialize it properly. Don't do any validation for+    -- @GraphQL@ built-in types here.+    --+    -- If the value cannot be serialized without losing information, return+    -- 'Nothing' — it will cause a field error.+    serialize :: forall m+        . Out.Type m -- ^ Expected output type.+        -> Output a -- ^ The value to be serialized.+        -> Maybe a -- ^ Serialized value on success or 'Nothing'.+    -- | __null__ representation in the given serialization format.+    null :: a++-- | Intermediate type used to serialize a @GraphQL@ value.+--+-- The serialization is done during the execution, and 'Output' contains+-- already serialized data (in 'List' and 'Object') as well as the new layer+-- that has to be serialized in the current step. So 'Output' is parameterized+-- by the serialization format.+data Output a+    = Int Int32+    | Float Double+    | String Text+    | Boolean Bool+    | Enum Name+    | List [a]+    | Object (Map Name a)+    deriving (Eq, Show)++instance forall a. IsString (Output a) where+    fromString = String . fromString++instance Serialize Aeson.Value where+    serialize (Out.ScalarBaseType scalarType) value+        | Type.ScalarType "Int" _ <- scalarType+        , Int int <- value = Just $ Aeson.toJSON int+        | Type.ScalarType "Float" _ <- scalarType+        , Float float <- value = Just $ Aeson.toJSON float+        | Type.ScalarType "String" _ <- scalarType+        , String string <- value = Just $ Aeson.String string+        | Type.ScalarType "ID" _ <- scalarType+        , String string <- value = Just $ Aeson.String string+        | Type.ScalarType "Boolean" _ <- scalarType+        , Boolean boolean <- value = Just $ Aeson.Bool boolean+    serialize _ (Enum enum) = Just $ Aeson.String enum+    serialize _ (List list) = Just $ Aeson.toJSON list+    serialize _ (Object object) = Just $ Aeson.toJSON object+    serialize _ _ = Nothing+    null = Aeson.Null

@@ -0,0 +1,229 @@+{-# LANGUAGE ExplicitForAll #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ViewPatterns #-}++module Language.GraphQL.Execute.Execution+    ( executeSelectionSet+    ) where++import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.Except (runExceptT)+import Control.Monad.Trans.Reader (runReaderT)+import Control.Monad.Trans.State (gets)+import Data.List.NonEmpty (NonEmpty(..))+import Data.Map.Strict (Map)+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HashMap+import qualified Data.Map.Strict as Map+import Data.Maybe (fromMaybe)+import Data.Sequence (Seq(..))+import Data.Text (Text)+import Language.GraphQL.AST (Name)+import Language.GraphQL.AST.Core+import Language.GraphQL.Error+import Language.GraphQL.Execute.Coerce+import qualified Language.GraphQL.Execute.Transform as Transform+import Language.GraphQL.Trans+import qualified Language.GraphQL.Type as Type+import qualified Language.GraphQL.Type.In as In+import qualified Language.GraphQL.Type.Out as Out+import Language.GraphQL.Type.Schema+import Prelude hiding (null)++resolveFieldValue :: Monad m+    => Type.Value+    -> Type.Subs+    -> ActionT m a+    -> m (Either Text a)+resolveFieldValue result args =+    flip runReaderT (Context {arguments = Arguments args, values = result})+    . runExceptT+    . runActionT++collectFields :: Monad m+    => Out.ObjectType m+    -> Seq (Transform.Selection m)+    -> Map Name (NonEmpty (Transform.Field m))+collectFields objectType = foldl forEach Map.empty+  where+    forEach groupedFields (Transform.SelectionField field) =+        let responseKey = aliasOrName field+         in Map.insertWith (<>) responseKey (field :| []) groupedFields+    forEach groupedFields (Transform.SelectionFragment selectionFragment)+        | Transform.Fragment fragmentType fragmentSelectionSet <- selectionFragment+        , doesFragmentTypeApply fragmentType objectType =+            let fragmentGroupedFieldSet = collectFields objectType fragmentSelectionSet+             in Map.unionWith (<>) groupedFields fragmentGroupedFieldSet+        | otherwise = groupedFields++aliasOrName :: forall m. Transform.Field m -> Name+aliasOrName (Transform.Field alias name _ _) = fromMaybe name alias++resolveAbstractType :: Monad m+    => AbstractType m+    -> Type.Subs+    -> CollectErrsT m (Maybe (Out.ObjectType m))+resolveAbstractType abstractType values'+    | Just (Type.String typeName) <- HashMap.lookup "__typename" values' = do+        types' <- gets types+        case HashMap.lookup typeName types' of+            Just (ObjectType objectType) ->+                if instanceOf objectType abstractType+                    then pure $ Just objectType+                    else pure Nothing+            _ -> pure Nothing+    | otherwise = pure Nothing++doesFragmentTypeApply :: forall m+    . CompositeType m+    -> Out.ObjectType m+    -> Bool+doesFragmentTypeApply (CompositeObjectType fragmentType) objectType =+    fragmentType == objectType+doesFragmentTypeApply (CompositeInterfaceType fragmentType) objectType =+    instanceOf objectType $ AbstractInterfaceType fragmentType+doesFragmentTypeApply (CompositeUnionType fragmentType) objectType =+    instanceOf objectType $ AbstractUnionType fragmentType++instanceOf :: forall m. Out.ObjectType m -> AbstractType m -> Bool+instanceOf objectType (AbstractInterfaceType interfaceType) =+    let Out.ObjectType _ _ interfaces _ = objectType+     in foldr go False interfaces+  where+    go objectInterfaceType@(Out.InterfaceType _ _ interfaces _) acc =+        acc || foldr go (interfaceType == objectInterfaceType) interfaces+instanceOf objectType (AbstractUnionType unionType) =+    let Out.UnionType _ _ members = unionType+     in foldr go False members+  where+    go unionMemberType acc = acc || objectType == unionMemberType++executeField :: (Monad m, Serialize a)+    => Out.Resolver m+    -> Type.Value+    -> NonEmpty (Transform.Field m)+    -> CollectErrsT m a+executeField (Out.Resolver fieldDefinition resolver) prev fields = do+    let Out.Field _ fieldType argumentDefinitions = fieldDefinition+    let (Transform.Field _ _ arguments' _ :| []) = fields+    case coerceArgumentValues argumentDefinitions arguments' of+        Nothing -> errmsg "Argument coercing failed."+        Just argumentValues -> do+            answer <- lift $ resolveFieldValue prev argumentValues resolver+            case answer of+                Right result -> completeValue fieldType fields result+                Left errorMessage -> errmsg errorMessage++completeValue :: (Monad m, Serialize a)+    => Out.Type m+    -> NonEmpty (Transform.Field m)+    -> Type.Value+    -> CollectErrsT m a+completeValue (Out.isNonNullType -> False) _ Type.Null = pure null+completeValue outputType@(Out.ListBaseType listType) fields (Type.List list)+    = traverse (completeValue listType fields) list+    >>= coerceResult outputType . List+completeValue outputType@(Out.ScalarBaseType _) _ (Type.Int int) =+    coerceResult outputType $ Int int+completeValue outputType@(Out.ScalarBaseType _) _ (Type.Boolean boolean) =+    coerceResult outputType $ Boolean boolean+completeValue outputType@(Out.ScalarBaseType _) _ (Type.Float float) =+    coerceResult outputType $ Float float+completeValue outputType@(Out.ScalarBaseType _) _ (Type.String string) =+    coerceResult outputType $ String string+completeValue outputType@(Out.EnumBaseType enumType) _ (Type.Enum enum) =+    let Type.EnumType _ _ enumMembers = enumType+     in if HashMap.member enum enumMembers+        then coerceResult outputType $ Enum enum+        else errmsg "Value completion failed."+completeValue (Out.ObjectBaseType objectType) fields result =+    executeSelectionSet result objectType $ mergeSelectionSets fields+completeValue (Out.InterfaceBaseType interfaceType) fields result+    | Type.Object objectMap <- result = do+        let abstractType = AbstractInterfaceType interfaceType+        concreteType <- resolveAbstractType abstractType objectMap+        case concreteType of+            Just objectType -> executeSelectionSet result objectType+                $ mergeSelectionSets fields+            Nothing -> errmsg "Value completion failed."+completeValue (Out.UnionBaseType unionType) fields result+    | Type.Object objectMap <- result = do+        let abstractType = AbstractUnionType unionType+        concreteType <- resolveAbstractType abstractType objectMap+        case concreteType of+            Just objectType -> executeSelectionSet result objectType+                $ mergeSelectionSets fields+            Nothing -> errmsg "Value completion failed."+completeValue _ _ _ = errmsg "Value completion failed."++mergeSelectionSets :: Monad m => NonEmpty (Transform.Field m) -> Seq (Transform.Selection m)+mergeSelectionSets = foldr forEach mempty+  where+    forEach (Transform.Field _ _ _ fieldSelectionSet) selectionSet =+        selectionSet <> fieldSelectionSet++errmsg :: (Monad m, Serialize a) => Text -> CollectErrsT m a+errmsg errorMessage = addErrMsg errorMessage >> pure null++coerceResult :: (Monad m, Serialize a)+    => Out.Type m+    -> Output a+    -> CollectErrsT m a+coerceResult outputType result+    | Just serialized <- serialize outputType result = pure serialized+    | otherwise = errmsg "Result coercion failed."++-- | Takes an 'Out.ObjectType' and a list of 'Transform.Selection's and applies+-- each field to each 'Transform.Selection'. Resolves into a value containing+-- the resolved 'Transform.Selection', or a null value and error information.+executeSelectionSet :: (Monad m, Serialize a)+    => Type.Value+    -> Out.ObjectType m+    -> Seq (Transform.Selection m)+    -> CollectErrsT m a+executeSelectionSet result objectType@(Out.ObjectType _ _ _ resolvers) selectionSet = do+    let fields = collectFields objectType selectionSet+    resolvedValues <- Map.traverseMaybeWithKey forEach fields+    coerceResult (Out.NonNullObjectType objectType) $ Object resolvedValues+  where+    forEach _ fields@(field :| _) =+        let Transform.Field _ name _ _ = field+         in traverse (tryResolver fields) $ lookupResolver name+    lookupResolver = flip HashMap.lookup resolvers+    tryResolver fields resolver =+        executeField resolver result fields >>= lift . pure++coerceArgumentValues+    :: HashMap Name In.Argument+    -> HashMap Name Transform.Input+    -> Maybe Type.Subs+coerceArgumentValues argumentDefinitions argumentValues =+    HashMap.foldrWithKey forEach (pure mempty) argumentDefinitions+  where+    forEach variableName (In.Argument _ variableType defaultValue) =+        matchFieldValues coerceArgumentValue argumentValues variableName variableType defaultValue+    coerceArgumentValue inputType (Transform.Int integer) =+        coerceInputLiteral inputType (Type.Int integer)+    coerceArgumentValue inputType (Transform.Boolean boolean) =+        coerceInputLiteral inputType (Type.Boolean boolean)+    coerceArgumentValue inputType (Transform.String string) =+        coerceInputLiteral inputType (Type.String string)+    coerceArgumentValue inputType (Transform.Float float) =+        coerceInputLiteral inputType (Type.Float float)+    coerceArgumentValue inputType (Transform.Enum enum) =+        coerceInputLiteral inputType (Type.Enum enum)+    coerceArgumentValue inputType Transform.Null+        | In.isNonNullType inputType = Nothing+        | otherwise = coerceInputLiteral inputType Type.Null+    coerceArgumentValue (In.ListBaseType inputType) (Transform.List list) =+        let coerceItem = coerceInputLiteral inputType+         in Type.List <$> traverse coerceItem list+    coerceArgumentValue (In.InputObjectBaseType inputType) (Transform.Object object)+        | In.InputObjectType _ _ inputFields <- inputType = +            let go = forEachField object+                resultMap = HashMap.foldrWithKey go (pure mempty) inputFields+             in Type.Object <$> resultMap+    coerceArgumentValue _ (Transform.Variable variable) = pure variable+    coerceArgumentValue _ _ = Nothing+    forEachField object variableName (In.InputField _ variableType defaultValue) =+        matchFieldValues coerceArgumentValue object variableName variableType defaultValue

@@ -1,125 +1,356 @@ {-# LANGUAGE ExplicitForAll #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TupleSections #-} --- | After the document is parsed, before getting executed the AST is---   transformed into a similar, simpler AST. This module is responsible for---   this transformation.+-- | After the document is parsed, before getting executed, the AST is+-- transformed into a similar, simpler AST. Performed transformations include:+--+--   * Replacing variables with their values.+--   * Inlining fragments. Some fragments can be completely eliminated and+--   replaced by the selection set they represent. Invalid (recursive and+--   non-existing) fragments are skipped. The most fragments are inlined, so the+--   executor doesn't have to perform additional lookups later.+--   * Evaluating directives (@\@include@ and @\@skip@).+--+-- This module is also responsible for smaller rewrites that touch only parts of+-- the original AST. module Language.GraphQL.Execute.Transform-    ( document+    ( Document(..)+    , Field(..)+    , Fragment(..)+    , Input(..)+    , Operation(..)+    , QueryError(..)+    , Selection(..)+    , document+    , queryError     ) where -import Control.Arrow (first) import Control.Monad (foldM, unless) import Control.Monad.Trans.Class (lift)-import Control.Monad.Trans.Reader (ReaderT, asks, runReaderT)-import Control.Monad.Trans.State (StateT, evalStateT, gets, modify)+import Control.Monad.Trans.State (State, evalStateT, gets, modify)+import Data.Foldable (find)+import Data.Functor.Identity (Identity(..)) import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap+import Data.Int (Int32)+import Data.Maybe (fromMaybe)+import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.List.NonEmpty as NonEmpty import Data.Sequence (Seq, (<|), (><))+import Data.Text (Text)+import qualified Data.Text as Text import qualified Language.GraphQL.AST as Full-import qualified Language.GraphQL.AST.Core as Core-import Language.GraphQL.AST.Document (Definition(..), Document)-import qualified Language.GraphQL.Schema as Schema+import Language.GraphQL.AST (Name)+import Language.GraphQL.AST.Core+import qualified Language.GraphQL.Execute.Coerce as Coerce+import Language.GraphQL.Type.Directive (Directive(..)) import qualified Language.GraphQL.Type.Directive as Directive+import qualified Language.GraphQL.Type as Type+import qualified Language.GraphQL.Type.In as In+import qualified Language.GraphQL.Type.Out as Out+import Language.GraphQL.Type.Schema --- | Associates a fragment name with a list of 'Core.Field's.-data Replacement = Replacement-    { fragments :: HashMap Core.Name Core.Fragment-    , fragmentDefinitions :: HashMap Full.Name Full.FragmentDefinition+-- | Associates a fragment name with a list of 'Field's.+data Replacement m = Replacement+    { fragments :: HashMap Full.Name (Fragment m)+    , fragmentDefinitions :: FragmentDefinitions+    , variableValues :: Type.Subs+    , types :: HashMap Full.Name (Type m)     } -type TransformT a = StateT Replacement (ReaderT Schema.Subs Maybe) a+type FragmentDefinitions = HashMap Full.Name Full.FragmentDefinition -liftJust :: forall a. a -> TransformT a-liftJust = lift . lift . Just+-- | Represents fragments and inline fragments.+data Fragment m+    = Fragment (CompositeType m) (Seq (Selection m)) +-- | Single selection element.+data Selection m+    = SelectionFragment (Fragment m)+    | SelectionField (Field m)++-- | GraphQL has 3 operation types: queries, mutations and subscribtions.+--+-- Currently only queries and mutations are supported.+data Operation m+    = Query (Maybe Text) (Seq (Selection m))+    | Mutation (Maybe Text) (Seq (Selection m))++-- | Single GraphQL field.+data Field m = Field+    (Maybe Full.Name) Full.Name (HashMap Full.Name Input) (Seq (Selection m))++-- | Contains the operation to be executed along with its root type.+data Document m = Document+    (HashMap Full.Name (Type m)) (Out.ObjectType m) (Operation m)++data OperationDefinition = OperationDefinition+    Full.OperationType+    (Maybe Full.Name)+    [Full.VariableDefinition]+    [Full.Directive]+    Full.SelectionSet++-- | Query error types.+data QueryError+    = OperationNotFound Text+    | OperationNameRequired+    | CoercionError+    | TransformationError+    | EmptyDocument+    | UnsupportedRootOperation++data Input+    = Int Int32+    | Float Double+    | String Text+    | Boolean Bool+    | Null+    | Enum Name+    | List [Type.Value]+    | Object (HashMap Name Input)+    | Variable Type.Value+    deriving (Eq, Show)++queryError :: QueryError -> Text+queryError (OperationNotFound operationName) = Text.unwords+    ["Operation", operationName, "couldn't be found in the document."]+queryError OperationNameRequired = "Missing operation name."+queryError CoercionError = "Coercion error."+queryError TransformationError = "Schema transformation error."+queryError EmptyDocument =+    "The document doesn't contain any executable operations."+queryError UnsupportedRootOperation =+    "Root operation type couldn't be found in the schema."++getOperation+    :: Maybe Full.Name+    -> NonEmpty OperationDefinition+    -> Either QueryError OperationDefinition+getOperation Nothing (operation' :| []) = pure operation'+getOperation Nothing _ = Left OperationNameRequired+getOperation (Just operationName) operations+    | Just operation' <- find matchingName operations = pure operation'+    | otherwise = Left $ OperationNotFound operationName+  where+    matchingName (OperationDefinition _ name _ _ _) =+        name == Just operationName++lookupInputType+    :: Full.Type+    -> HashMap.HashMap Full.Name (Type m)+    -> Maybe In.Type+lookupInputType (Full.TypeNamed name) types =+    case HashMap.lookup name types of+        Just (ScalarType scalarType) ->+            Just $ In.NamedScalarType scalarType+        Just (EnumType enumType) ->+            Just $ In.NamedEnumType enumType+        Just (InputObjectType objectType) ->+            Just $ In.NamedInputObjectType objectType+        _ -> Nothing+lookupInputType (Full.TypeList list) types+    = In.ListType+    <$> lookupInputType list types+lookupInputType (Full.TypeNonNull (Full.NonNullTypeNamed nonNull)) types  =+    case HashMap.lookup nonNull types of+        Just (ScalarType scalarType) ->+            Just $ In.NonNullScalarType scalarType+        Just (EnumType enumType) ->+            Just $ In.NonNullEnumType enumType+        Just (InputObjectType objectType) ->+            Just $ In.NonNullInputObjectType objectType+        _ -> Nothing+lookupInputType (Full.TypeNonNull (Full.NonNullTypeList nonNull)) types+    = In.NonNullListType+    <$> lookupInputType nonNull types++coerceVariableValues :: Coerce.VariableValue a+    => forall m+    . HashMap Full.Name (Type m)+    -> OperationDefinition+    -> HashMap.HashMap Full.Name a+    -> Either QueryError Type.Subs+coerceVariableValues types operationDefinition variableValues =+    let OperationDefinition _ _ variableDefinitions _ _ = operationDefinition+     in maybe (Left CoercionError) Right+        $ foldr forEach (Just HashMap.empty) variableDefinitions+  where+    forEach variableDefinition coercedValues = do+        let Full.VariableDefinition variableName variableTypeName defaultValue =+                variableDefinition+        let defaultValue' = constValue <$> defaultValue+        variableType <- lookupInputType variableTypeName types++        Coerce.matchFieldValues+            coerceVariableValue'+            variableValues+            variableName+            variableType+            defaultValue'+            coercedValues+    coerceVariableValue' variableType value'+        = Coerce.coerceVariableValue variableType value'+        >>= Coerce.coerceInputLiteral variableType++constValue :: Full.ConstValue -> Type.Value+constValue (Full.ConstInt i) = Type.Int i+constValue (Full.ConstFloat f) = Type.Float f+constValue (Full.ConstString x) = Type.String x+constValue (Full.ConstBoolean b) = Type.Boolean b+constValue Full.ConstNull = Type.Null+constValue (Full.ConstEnum e) = Type.Enum e+constValue (Full.ConstList l) = Type.List $ constValue <$> l+constValue (Full.ConstObject o) =+    Type.Object $ HashMap.fromList $ constObjectField <$> o+  where+    constObjectField (Full.ObjectField key value') = (key, constValue value')+ -- | Rewrites the original syntax tree into an intermediate representation used -- for query execution.-document :: Schema.Subs -> Document -> Maybe Core.Document-document subs document' =-    flip runReaderT subs-        $ evalStateT (collectFragments >> operations operationDefinitions)-        $ Replacement HashMap.empty fragmentTable+document :: Coerce.VariableValue a+    => forall m+    . Schema m+    -> Maybe Full.Name+    -> HashMap Full.Name a+    -> Full.Document+    -> Either QueryError (Document m)+document schema operationName subs ast = do+    let referencedTypes = collectReferencedTypes schema++    (operations, fragmentTable) <- defragment ast+    chosenOperation <- getOperation operationName operations+    coercedValues <- coerceVariableValues referencedTypes chosenOperation subs++    let replacement = Replacement+            { fragments = HashMap.empty+            , fragmentDefinitions = fragmentTable+            , variableValues = coercedValues+            , types = referencedTypes+            }+    case chosenOperation of+        OperationDefinition Full.Query _ _ _ _ ->+            pure $ Document referencedTypes (query schema)+                $ operation chosenOperation replacement+        OperationDefinition Full.Mutation _ _ _ _+            | Just mutationType <- mutation schema ->+                pure $ Document referencedTypes mutationType+                    $ operation chosenOperation replacement+        _ -> Left UnsupportedRootOperation++defragment+    :: Full.Document+    -> Either QueryError (NonEmpty OperationDefinition, FragmentDefinitions)+defragment ast =+    let (operations, fragmentTable) = foldr defragment' ([], HashMap.empty) ast+        nonEmptyOperations = NonEmpty.nonEmpty operations+        emptyDocument = Left EmptyDocument+     in (, fragmentTable) <$> maybe emptyDocument Right nonEmptyOperations   where-    (fragmentTable, operationDefinitions) = foldr defragment mempty document'-    defragment (ExecutableDefinition (Full.DefinitionOperation definition)) acc =-        (definition :) <$> acc-    defragment (ExecutableDefinition (Full.DefinitionFragment definition)) acc =-        let (Full.FragmentDefinition name _ _ _) = definition-         in first (HashMap.insert name definition) acc-    defragment _ acc = acc+    defragment' definition (operations, fragments')+        | (Full.ExecutableDefinition executable) <- definition+        , (Full.DefinitionOperation operation') <- executable =+            (transform operation' : operations, fragments')+        | (Full.ExecutableDefinition executable) <- definition+        , (Full.DefinitionFragment fragment) <- executable+        , (Full.FragmentDefinition name _ _ _) <- fragment =+            (operations, HashMap.insert name fragment fragments')+    defragment' _ acc = acc+    transform = \case+        Full.OperationDefinition type' name variables directives' selections ->+            OperationDefinition type' name variables directives' selections+        Full.SelectionSet selectionSet ->+            OperationDefinition Full.Query Nothing mempty mempty selectionSet  -- * Operation -operations :: [Full.OperationDefinition] -> TransformT Core.Document-operations operations' = do-    coreOperations <- traverse operation operations'-    lift . lift $ NonEmpty.nonEmpty coreOperations--operation :: Full.OperationDefinition -> TransformT Core.Operation-operation (Full.SelectionSet sels)-    = operation $ Full.OperationDefinition Full.Query mempty mempty mempty sels-operation (Full.OperationDefinition Full.Query name _vars _dirs sels)-    = Core.Query name <$> appendSelection sels-operation (Full.OperationDefinition Full.Mutation name _vars _dirs sels)-    = Core.Mutation name <$> appendSelection sels+operation :: OperationDefinition -> Replacement m -> Operation m+operation operationDefinition replacement+    = runIdentity+    $ evalStateT (collectFragments >> transform operationDefinition) replacement+  where+    transform (OperationDefinition Full.Query name _ _ sels) =+        Query name <$> appendSelection sels+    transform (OperationDefinition Full.Mutation name _ _ sels) =+        Mutation name <$> appendSelection sels  -- * Selection -selection ::-    Full.Selection ->-    TransformT (Either (Seq Core.Selection) Core.Selection)+selection+    :: Full.Selection+    ->  State (Replacement m) (Either (Seq (Selection m)) (Selection m)) selection (Full.Field alias name arguments' directives' selections) =-    maybe (Left mempty) (Right . Core.SelectionField) <$> do-        fieldArguments <- arguments arguments'+    maybe (Left mempty) (Right . SelectionField) <$> do+        fieldArguments <- foldM go HashMap.empty arguments'         fieldSelections <- appendSelection selections         fieldDirectives <- Directive.selection <$> directives directives'-        let field' = Core.Field alias name fieldArguments fieldSelections+        let field' = Field alias name fieldArguments fieldSelections         pure $ field' <$ fieldDirectives+  where+    go arguments (Full.Argument name' value') =+        inputField arguments name' value'+ selection (Full.FragmentSpread name directives') =-    maybe (Left mempty) (Right . Core.SelectionFragment) <$> do+    maybe (Left mempty) (Right . SelectionFragment) <$> do         spreadDirectives <- Directive.selection <$> directives directives'         fragments' <- gets fragments-        fragment <- maybe lookupDefinition liftJust (HashMap.lookup name fragments')-        pure $ fragment <$ spreadDirectives-  where-    lookupDefinition = do+         fragmentDefinitions' <- gets fragmentDefinitions-        found <- lift . lift $ HashMap.lookup name fragmentDefinitions'-        fragmentDefinition found+        case HashMap.lookup name fragments' of+            Just definition -> lift $ pure $ definition <$ spreadDirectives+            Nothing+                | Just definition <- HashMap.lookup name fragmentDefinitions' -> do+                    fragDef <- fragmentDefinition definition+                    case fragDef of+                        Just fragment -> lift $ pure $ fragment <$ spreadDirectives+                        _ -> lift $ pure  Nothing+                | otherwise -> lift $ pure  Nothing selection (Full.InlineFragment type' directives' selections) = do     fragmentDirectives <- Directive.selection <$> directives directives'     case fragmentDirectives of         Nothing -> pure $ Left mempty         _ -> do             fragmentSelectionSet <- appendSelection selections-            pure $ maybe Left selectionFragment type' fragmentSelectionSet++            case type' of+                Nothing -> pure $ Left fragmentSelectionSet+                Just typeName -> do+                    typeCondition' <- lookupTypeCondition typeName+                    case typeCondition' of+                        Just typeCondition -> pure $+                            selectionFragment typeCondition fragmentSelectionSet+                        Nothing -> pure $ Left mempty   where     selectionFragment typeName = Right-        . Core.SelectionFragment-        . Core.Fragment typeName+        . SelectionFragment+        . Fragment typeName -appendSelection ::-    Traversable t =>-    t Full.Selection ->-    TransformT (Seq Core.Selection)+appendSelection :: Traversable t+    => t Full.Selection+    ->  State (Replacement m) (Seq (Selection m)) appendSelection = foldM go mempty   where     go acc sel = append acc <$> selection sel     append acc (Left list) = list >< acc     append acc (Right one) = one <| acc -directives :: [Full.Directive] -> TransformT [Core.Directive]+directives :: [Full.Directive] ->  State (Replacement m) [Directive] directives = traverse directive   where-    directive (Full.Directive directiveName directiveArguments) =-        Core.Directive directiveName <$> arguments directiveArguments+    directive (Full.Directive directiveName directiveArguments)+        = Directive directiveName . Arguments+        <$> foldM go HashMap.empty directiveArguments+    go arguments (Full.Argument name value') = do+        substitutedValue <- value value'+        return $ HashMap.insert name substitutedValue arguments  -- * Fragment replacement  -- | Extract fragment definitions into a single 'HashMap'.-collectFragments :: TransformT ()+collectFragments ::  State (Replacement m) () collectFragments = do     fragDefs <- gets fragmentDefinitions     let nextValue = head $ HashMap.elems fragDefs@@ -127,41 +358,79 @@         _ <- fragmentDefinition nextValue         collectFragments -fragmentDefinition ::-    Full.FragmentDefinition ->-    TransformT Core.Fragment+lookupTypeCondition :: Full.Name -> State (Replacement m) (Maybe (CompositeType m))+lookupTypeCondition type' = do+    types' <- gets types+    case HashMap.lookup type' types' of+        Just (ObjectType objectType) ->+            lift $ pure $ Just $ CompositeObjectType objectType+        Just (UnionType unionType) ->+            lift $ pure $ Just $ CompositeUnionType unionType+        Just (InterfaceType interfaceType) ->+            lift $ pure $ Just $ CompositeInterfaceType interfaceType+        _ -> lift $ pure Nothing++fragmentDefinition+    :: Full.FragmentDefinition+    ->  State (Replacement m) (Maybe (Fragment m)) fragmentDefinition (Full.FragmentDefinition name type' _ selections) = do     modify deleteFragmentDefinition     fragmentSelection <- appendSelection selections-    let newValue = Core.Fragment type' fragmentSelection-    modify $ insertFragment newValue-    liftJust newValue+    compositeType <- lookupTypeCondition type'++    case compositeType of+        Just compositeType' -> do+            let newValue = Fragment compositeType' fragmentSelection+            modify $ insertFragment newValue+            lift $ pure $ Just newValue+        _ -> lift $ pure Nothing   where-    deleteFragmentDefinition (Replacement fragments' fragmentDefinitions') =-        Replacement fragments' $ HashMap.delete name fragmentDefinitions'-    insertFragment newValue (Replacement fragments' fragmentDefinitions') =-        let newFragments = HashMap.insert name newValue fragments'-         in Replacement newFragments fragmentDefinitions'+    deleteFragmentDefinition replacement@Replacement{..} =+        let newDefinitions = HashMap.delete name fragmentDefinitions+         in replacement{ fragmentDefinitions = newDefinitions }+    insertFragment newValue replacement@Replacement{..} =+        let newFragments = HashMap.insert name newValue fragments+         in replacement{ fragments = newFragments } -arguments :: [Full.Argument] -> TransformT Core.Arguments-arguments = fmap Core.Arguments . foldM go HashMap.empty+value :: forall m. Full.Value -> State (Replacement m) Type.Value+value (Full.Variable name) =+    gets (fromMaybe Type.Null . HashMap.lookup name . variableValues)+value (Full.Int int) = pure $ Type.Int int+value (Full.Float float) = pure $ Type.Float float+value (Full.String string) = pure $ Type.String string+value (Full.Boolean boolean) = pure $ Type.Boolean boolean+value Full.Null = pure Type.Null+value (Full.Enum enum) = pure $ Type.Enum enum+value (Full.List list) = Type.List <$> traverse value list+value (Full.Object object) =+    Type.Object . HashMap.fromList <$> traverse objectField object   where-    go arguments' (Full.Argument name value') = do-        substitutedValue <- value value'-        return $ HashMap.insert name substitutedValue arguments'+    objectField (Full.ObjectField name value') = (name,) <$> value value' -value :: Full.Value -> TransformT Core.Value-value (Full.Variable name) = lift (asks $ HashMap.lookup name) >>= lift . lift-value (Full.Int i) = pure $ Core.Int i-value (Full.Float f) = pure $ Core.Float f-value (Full.String x) = pure $ Core.String x-value (Full.Boolean b) = pure $ Core.Boolean b-value Full.Null = pure   Core.Null-value (Full.Enum e) = pure $ Core.Enum e-value (Full.List l) =-    Core.List <$> traverse value l-value (Full.Object o) =-    Core.Object . HashMap.fromList <$> traverse objectField o+input :: forall m. Full.Value -> State (Replacement m) (Maybe Input)+input (Full.Variable name) =+    gets (fmap Variable . HashMap.lookup name . variableValues)+input (Full.Int int) = pure $ pure $ Int int+input (Full.Float float) = pure $ pure $ Float float+input (Full.String string) = pure $ pure $ String string+input (Full.Boolean boolean) = pure $ pure $ Boolean boolean+input Full.Null = pure $ pure Null+input (Full.Enum enum) = pure $ pure $ Enum enum+input (Full.List list) = pure . List <$> traverse value list+input (Full.Object object) = do+    objectFields <- foldM objectField HashMap.empty object+    pure $ pure $ Object objectFields+  where+    objectField resultMap (Full.ObjectField name value') =+        inputField resultMap name value' -objectField :: Full.ObjectField -> TransformT (Core.Name, Core.Value)-objectField (Full.ObjectField name value') = (name,) <$> value value'+inputField :: forall m+    . HashMap Full.Name Input+    -> Full.Name+    -> Full.Value+    -> State (Replacement m) (HashMap Full.Name Input)+inputField resultMap name value' = do+    objectFieldValue <-  input value'+    case objectFieldValue of+        Just fieldValue -> pure $ HashMap.insert name fieldValue resultMap+        Nothing -> pure resultMap

@@ -1,138 +0,0 @@-{-# 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(..)-    , Subs-    , object-    , resolve-    , resolversToMap-    , scalar-    , wrappedObject-    , wrappedScalar-    -- * AST Reexports-    , Field-    , Value(..)-    ) where--import Control.Monad.Trans.Class (lift)-import Control.Monad.Trans.Except (runExceptT)-import Control.Monad.Trans.Reader (runReaderT)-import Data.Foldable (fold, toList)-import Data.Maybe (fromMaybe)-import qualified Data.Aeson as Aeson-import Data.HashMap.Strict (HashMap)-import qualified Data.HashMap.Strict as HashMap-import Data.Sequence (Seq)-import Data.Text (Text)-import qualified Data.Text as T-import Language.GraphQL.AST.Core-import Language.GraphQL.Error-import Language.GraphQL.Trans-import qualified Language.GraphQL.Type as Type---- | Resolves a 'Field' into an @Aeson.@'Data.Aeson.Types.Object' with error---   information (if an error has occurred). @m@ is an arbitrary monad, usually---   'IO'.-data Resolver m = Resolver-    Text -- ^ Name-    (Field -> CollectErrsT m Aeson.Object) -- ^ Resolver---- | Converts resolvers to a map.-resolversToMap-    :: (Foldable f, Functor f)-    => f (Resolver m)-    -> HashMap Text (Field -> CollectErrsT m Aeson.Object)-resolversToMap = HashMap.fromList . toList . fmap toKV-  where-    toKV (Resolver name f) = (name, f)---- | Contains variables for the query. The key of the map is a variable name,---   and the value is the variable value.-type Subs = HashMap Name Value---- | Create a new 'Resolver' with the given 'Name' from the given 'Resolver's.-object :: Monad m => Name -> ActionT m [Resolver m] -> Resolver m-object name f = Resolver name $ resolveFieldValue f resolveRight-  where-    resolveRight fld@(Field _ _ _ flds) resolver-        = withField (resolve (resolversToMap resolver) flds) fld---- | Like 'object' but can be null or a list of objects.-wrappedObject ::-    Monad m =>-    Name ->-    ActionT m (Type.Wrapping [Resolver m]) ->-    Resolver m-wrappedObject name f = Resolver name $ resolveFieldValue f resolveRight-  where-    resolveRight fld@(Field _ _ _ sels) resolver-        = withField (traverse (resolveMap sels) resolver) fld-    resolveMap = flip (resolve . resolversToMap)---- | A scalar represents a primitive value, like a string or an integer.-scalar :: (Monad m, Aeson.ToJSON a) => Name -> ActionT m a -> Resolver m-scalar name f = Resolver name $ resolveFieldValue f resolveRight-  where-    resolveRight fld result = withField (return result) fld---- | Like 'scalar' but can be null or a list of scalars.-wrappedScalar ::-    (Monad m, Aeson.ToJSON a) =>-    Name ->-    ActionT m (Type.Wrapping a) ->-    Resolver m-wrappedScalar name f = Resolver name $ resolveFieldValue f resolveRight-  where-    resolveRight fld (Type.Named result) = withField (return result) fld-    resolveRight fld Type.Null-        = return $ HashMap.singleton (aliasOrName fld) Aeson.Null-    resolveRight fld (Type.List result) = withField (return result) fld--resolveFieldValue ::-    Monad m =>-    ActionT m a ->-    (Field -> a -> CollectErrsT m Aeson.Object) ->-    Field ->-    CollectErrsT m (HashMap Text Aeson.Value)-resolveFieldValue f resolveRight fld@(Field _ _ args _) = do-    result <- lift $ reader . runExceptT . runActionT $ f-    either resolveLeft (resolveRight fld) result-      where-        reader = flip runReaderT $ Context {arguments=args}-        resolveLeft err = do-            _ <- addErrMsg err-            return $ HashMap.singleton (aliasOrName fld) Aeson.Null---- | Helper function to facilitate error handling and result emitting.-withField :: (Monad m, Aeson.ToJSON a)-    => CollectErrsT m a -> Field -> CollectErrsT m (HashMap Text Aeson.Value)-withField v fld-    = HashMap.singleton (aliasOrName fld) . Aeson.toJSON <$> runAppendErrs v---- | 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 :: Monad m-    => HashMap Text (Field -> CollectErrsT m Aeson.Object)-    -> Seq Selection-    -> CollectErrsT m Aeson.Value-resolve resolvers = fmap (Aeson.toJSON . fold) . traverse tryResolvers-  where-    resolveTypeName f = do-        value <- f $ Field Nothing "__typename" mempty mempty-        return $ HashMap.lookupDefault "" "__typename" value-    tryResolvers (SelectionField fld@(Field _ name _ _))-        = fromMaybe (errmsg fld) $ HashMap.lookup name resolvers <*> Just fld-    tryResolvers (SelectionFragment (Fragment typeCondition selections')) = do-        that <- traverse resolveTypeName $ HashMap.lookup "__typename" resolvers-        if maybe True (Aeson.String typeCondition ==) that-            then fmap fold . traverse tryResolvers $ selections'-            else return mempty-    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

@@ -1,8 +1,8 @@ -- | Monad transformer stack used by the @GraphQL@ resolvers. module Language.GraphQL.Trans-    ( ActionT(..)+    ( argument+    , ActionT(..)     , Context(..)-    , argument     ) where  import Control.Applicative (Alternative(..))@@ -14,12 +14,15 @@ import qualified Data.HashMap.Strict as HashMap import Data.Maybe (fromMaybe) import Data.Text (Text)+import Language.GraphQL.AST (Name) import Language.GraphQL.AST.Core+import Language.GraphQL.Type.Definition import Prelude hiding (lookup)  -- | Resolution context holds resolver arguments.-newtype Context = Context+data Context = Context     { arguments :: Arguments+    , values :: Value     }  -- | Monad transformer stack used by the resolvers to provide error handling@@ -54,7 +57,7 @@     mplus = (<|>)  -- | Retrieves an argument by its name. If the argument with this name couldn't---   be found, returns 'Value.Null' (i.e. the argument is assumed to+--   be found, returns 'Null' (i.e. the argument is assumed to --   be optional then). argument :: Monad m => Name -> ActionT m Value argument argumentName = do

@@ -1,55 +1,16 @@--- | Definitions for @GraphQL@ input types.+-- | Reexports non-conflicting type system and schema definitions. module Language.GraphQL.Type-    ( Wrapping(..)+    ( In.InputField(..)+    , In.InputObjectType(..)+    , Out.Field(..)+    , Out.InterfaceType(..)+    , Out.ObjectType(..)+    , Out.UnionType(..)+    , module Language.GraphQL.Type.Definition+    , module Language.GraphQL.Type.Schema     ) 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+import Language.GraphQL.Type.Definition+import Language.GraphQL.Type.Schema (Schema(..))+import qualified Language.GraphQL.Type.In as In+import qualified Language.GraphQL.Type.Out as Out

@@ -0,0 +1,115 @@+{-# LANGUAGE OverloadedStrings #-}++-- | Types that can be used as both input and output types.+module Language.GraphQL.Type.Definition+    ( EnumType(..)+    , EnumValue(..)+    , ScalarType(..)+    , Subs+    , Value(..)+    , boolean+    , float+    , id+    , int+    , string+    ) where++import Data.Int (Int32)+import Data.HashMap.Strict (HashMap)+import Data.String (IsString(..))+import Data.Text (Text)+import Language.GraphQL.AST.Document (Name)+import Prelude hiding (id)++-- | Represents accordingly typed GraphQL values.+data Value+    = Int Int32+    | Float Double -- ^ GraphQL Float is double precision.+    | String Text+    | Boolean Bool+    | Null+    | Enum Name+    | List [Value] -- ^ Arbitrary nested list.+    | Object (HashMap Name Value)+    deriving (Eq, Show)++instance IsString Value where+    fromString = String . fromString++-- | Contains variables for the query. The key of the map is a variable name,+-- and the value is the variable value.+type Subs = HashMap Name Value++-- | Scalar type definition.+--+-- The leaf values of any request and input values to arguments are Scalars (or+-- Enums) .+data ScalarType = ScalarType Name (Maybe Text)++instance Eq ScalarType where+    (ScalarType this _) == (ScalarType that _) = this == that++-- | Enum type definition.+--+-- Some leaf values of requests and input values are Enums. GraphQL serializes+-- Enum values as strings, however internally Enums can be represented by any+-- kind of type, often integers.+data EnumType = EnumType Name (Maybe Text) (HashMap Name EnumValue)++instance Eq EnumType where+    (EnumType this _ _) == (EnumType that _ _) = this == that++-- | Enum value is a single member of an 'EnumType'.+newtype EnumValue = EnumValue (Maybe Text)++-- | The @String@ scalar type represents textual data, represented as UTF-8+-- character sequences. The String type is most often used by GraphQL to+-- represent free-form human-readable text.+string :: ScalarType+string = ScalarType "String" (Just description)+  where+    description =+        "The `String` scalar type represents textual data, represented as \+        \UTF-8 character sequences. The String type is most often used by \+        \GraphQL to represent free-form human-readable text."++-- | The @Boolean@ scalar type represents @true@ or @false@.+boolean :: ScalarType+boolean = ScalarType "Boolean" (Just description)+  where+    description = "The `Boolean` scalar type represents `true` or `false`."++-- | The @Int@ scalar type represents non-fractional signed whole numeric+-- values. Int can represent values between \(-2^{31}\) and \(2^{31 - 1}\).+int :: ScalarType+int = ScalarType "Int" (Just description)+  where+    description =+        "The `Int` scalar type represents non-fractional signed whole numeric \+        \values. Int can represent values between -(2^31) and 2^31 - 1."++-- | The @Float@ scalar type represents signed double-precision fractional+-- values as specified by+-- [IEEE 754](https://en.wikipedia.org/wiki/IEEE_floating_point).+float :: ScalarType+float = ScalarType "Float" (Just description)+  where+    description =+        "The `Float` scalar type represents signed double-precision fractional \+        \values as specified by \+        \[IEEE 754](https://en.wikipedia.org/wiki/IEEE_floating_point)."++-- | The @ID@ scalar type represents a unique identifier, often used to refetch+-- an object or as key for a cache. The ID type appears in a JSON response as a+-- String; however, it is not intended to be human-readable. When expected as an+-- input type, any string (such as @"4"@) or integer (such as @4@) input value+-- will be accepted as an ID.+id :: ScalarType+id = ScalarType "ID" (Just description)+  where+    description =+        "The `ID` scalar type represents a unique identifier, often used to \+        \refetch an object or as key for a cache. The ID type appears in a \+        \JSON response as a String; however, it is not intended to be \+        \human-readable. When expected as an input type, any string (such as \+        \`\"4\"`) or integer (such as `4`) input value will be accepted as an ID."

@@ -1,11 +1,18 @@ {-# LANGUAGE OverloadedStrings #-}  module Language.GraphQL.Type.Directive-    ( selection+    ( Directive(..)+    , selection     ) where  import qualified Data.HashMap.Strict as HashMap+import Language.GraphQL.AST (Name) import Language.GraphQL.AST.Core+import Language.GraphQL.Type.Definition++-- | Directive.+data Directive = Directive Name Arguments+    deriving (Eq, Show)  -- | Directive processing status. data Status

@@ -0,0 +1,101 @@+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ViewPatterns #-}++-- | Input types and values.+--+-- This module is intended to be imported qualified, to avoid name clashes+-- with 'Language.GraphQL.Type.Out'.+module Language.GraphQL.Type.In+    ( Argument(..)+    , InputField(..)+    , InputObjectType(..)+    , Type(..)+    , isNonNullType+    , pattern EnumBaseType+    , pattern ListBaseType+    , pattern InputObjectBaseType+    , pattern ScalarBaseType+    ) where++import Data.HashMap.Strict (HashMap)+import Data.Text (Text)+import Language.GraphQL.AST.Document (Name)+import Language.GraphQL.Type.Definition++-- | Single field of an 'InputObjectType'.+data InputField = InputField (Maybe Text) Type (Maybe Value)++-- | Input object type definition.+--+-- An input object defines a structured collection of fields which may be+-- supplied to a field argument.+data InputObjectType = InputObjectType+    Name (Maybe Text) (HashMap Name InputField)++instance Eq InputObjectType where+    (InputObjectType this _ _) == (InputObjectType that _ _) = this == that++-- | These types may be used as input types for arguments and directives.+--+-- 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).+data Type+    = NamedScalarType ScalarType+    | NamedEnumType EnumType+    | NamedInputObjectType InputObjectType+    | ListType Type+    | NonNullScalarType ScalarType+    | NonNullEnumType EnumType+    | NonNullInputObjectType InputObjectType+    | NonNullListType Type+    deriving Eq++-- | Field argument definition.+data Argument = Argument (Maybe Text) Type (Maybe Value)++-- | Matches either 'NamedScalarType' or 'NonNullScalarType'.+pattern ScalarBaseType :: ScalarType -> Type+pattern ScalarBaseType scalarType <- (isScalarType -> Just scalarType)++-- | Matches either 'NamedEnumType' or 'NonNullEnumType'.+pattern EnumBaseType :: EnumType -> Type+pattern EnumBaseType enumType <- (isEnumType -> Just enumType)++-- | Matches either 'NamedInputObjectType' or 'NonNullInputObjectType'.+pattern InputObjectBaseType :: InputObjectType -> Type+pattern InputObjectBaseType objectType <- (isInputObjectType -> Just objectType)++-- | Matches either 'ListType' or 'NonNullListType'.+pattern ListBaseType :: Type -> Type+pattern ListBaseType listType <- (isListType -> Just listType)++{-# COMPLETE EnumBaseType, ListBaseType, InputObjectBaseType, ScalarBaseType #-}++isScalarType :: Type -> Maybe ScalarType+isScalarType (NamedScalarType inputType) = Just inputType+isScalarType (NonNullScalarType inputType) = Just inputType+isScalarType _ = Nothing++isInputObjectType :: Type -> Maybe InputObjectType+isInputObjectType (NamedInputObjectType inputType) = Just inputType+isInputObjectType (NonNullInputObjectType inputType) = Just inputType+isInputObjectType _ = Nothing++isEnumType :: Type -> Maybe EnumType+isEnumType (NamedEnumType inputType) = Just inputType+isEnumType (NonNullEnumType inputType) = Just inputType+isEnumType _ = Nothing++isListType :: Type -> Maybe Type+isListType (ListType inputType) = Just inputType+isListType (NonNullListType inputType) = Just inputType+isListType _ = Nothing++-- | Checks whether the given input type is a non-null type.+isNonNullType :: Type -> Bool+isNonNullType (NonNullScalarType _) = True+isNonNullType (NonNullEnumType _) = True+isNonNullType (NonNullInputObjectType _) = True+isNonNullType (NonNullListType _) = True+isNonNullType _ = False

@@ -0,0 +1,168 @@+{-# LANGUAGE ExplicitForAll #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ViewPatterns #-}++-- | Output types and values.+--+-- This module is intended to be imported qualified, to avoid name clashes+-- with 'Language.GraphQL.Type.In'.+module Language.GraphQL.Type.Out+    ( Field(..)+    , InterfaceType(..)+    , ObjectType(..)+    , Resolver(..)+    , Type(..)+    , UnionType(..)+    , isNonNullType+    , pattern EnumBaseType+    , pattern InterfaceBaseType+    , pattern ListBaseType+    , pattern ObjectBaseType+    , pattern ScalarBaseType+    , pattern UnionBaseType+    ) where++import Data.HashMap.Strict (HashMap)+import Data.Text (Text)+import Language.GraphQL.AST (Name)+import Language.GraphQL.Trans+import Language.GraphQL.Type.Definition+import qualified Language.GraphQL.Type.In as In++-- | Resolves a 'Field' into an @Aeson.@'Data.Aeson.Types.Object' with error+-- information (if an error has occurred). @m@ is an arbitrary monad, usually+-- 'IO'.+--+-- Resolving a field can result in a leaf value or an object, which is+-- represented as a list of nested resolvers, used to resolve the fields of that+-- object.+data Resolver m = Resolver (Field m) (ActionT m Value)++-- | Object type definition.+--+--   Almost all of the GraphQL types you define will be object types. Object+--   types have a name, but most importantly describe their fields.+data ObjectType m = ObjectType+    Name (Maybe Text) [InterfaceType m] (HashMap Name (Resolver m))++instance forall a. Eq (ObjectType a) where+    (ObjectType this _ _ _) == (ObjectType that _ _ _) = this == that++-- | Interface Type Definition.+--+-- When a field can return one of a heterogeneous set of types, a Interface type+-- is used to describe what types are possible, and what fields are in common+-- across all types.+data InterfaceType m = InterfaceType+    Name (Maybe Text) [InterfaceType m] (HashMap Name (Field m))++instance forall a. Eq (InterfaceType a) where+    (InterfaceType this _ _ _) == (InterfaceType that _ _ _) = this == that++-- | Union Type Definition.+--+-- When a field can return one of a heterogeneous set of types, a Union type is+-- used to describe what types are possible.+data UnionType m = UnionType Name (Maybe Text) [ObjectType m]++instance forall a. Eq (UnionType a) where+    (UnionType this _ _) == (UnionType that _ _) = this == that++-- | Output object field definition.+data Field m = Field+    (Maybe Text) -- ^ Description.+    (Type m) -- ^ Field type.+    (HashMap Name In.Argument) -- ^ Arguments.++-- | These types may be used as output types as the result of fields.+--+-- 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).+data Type m+    = NamedScalarType ScalarType+    | NamedEnumType EnumType+    | NamedObjectType (ObjectType m)+    | NamedInterfaceType (InterfaceType m)+    | NamedUnionType (UnionType m)+    | ListType (Type m)+    | NonNullScalarType ScalarType+    | NonNullEnumType EnumType+    | NonNullObjectType (ObjectType m)+    | NonNullInterfaceType (InterfaceType m)+    | NonNullUnionType (UnionType m)+    | NonNullListType (Type m)+    deriving Eq++-- | Matches either 'NamedScalarType' or 'NonNullScalarType'.+pattern ScalarBaseType :: forall m. ScalarType -> Type m+pattern ScalarBaseType scalarType <- (isScalarType -> Just scalarType)++-- | Matches either 'NamedEnumType' or 'NonNullEnumType'.+pattern EnumBaseType :: forall m. EnumType -> Type m+pattern EnumBaseType enumType <- (isEnumType -> Just enumType)++-- | Matches either 'NamedObjectType' or 'NonNullObjectType'.+pattern ObjectBaseType :: forall m. ObjectType m -> Type m+pattern ObjectBaseType objectType <- (isObjectType -> Just objectType)++-- | Matches either 'NamedInterfaceType' or 'NonNullInterfaceType'.+pattern InterfaceBaseType :: forall m. InterfaceType m -> Type m+pattern InterfaceBaseType interfaceType <-+    (isInterfaceType -> Just interfaceType)++-- | Matches either 'NamedUnionType' or 'NonNullUnionType'.+pattern UnionBaseType :: forall m. UnionType m -> Type m+pattern UnionBaseType unionType <- (isUnionType -> Just unionType)++-- | Matches either 'ListType' or 'NonNullListType'.+pattern ListBaseType :: forall m. Type m -> Type m+pattern ListBaseType listType <- (isListType -> Just listType)++{-# COMPLETE ScalarBaseType+    , EnumBaseType+    , ObjectBaseType+    , ListBaseType+    , InterfaceBaseType+    , UnionBaseType+    #-}++isScalarType :: forall m. Type m -> Maybe ScalarType+isScalarType (NamedScalarType outputType) = Just outputType+isScalarType (NonNullScalarType outputType) = Just outputType+isScalarType _ = Nothing++isObjectType :: forall m. Type m -> Maybe (ObjectType m)+isObjectType (NamedObjectType outputType) = Just outputType+isObjectType (NonNullObjectType outputType) = Just outputType+isObjectType _ = Nothing++isEnumType :: forall m. Type m -> Maybe EnumType+isEnumType (NamedEnumType outputType) = Just outputType+isEnumType (NonNullEnumType outputType) = Just outputType+isEnumType _ = Nothing++isInterfaceType :: forall m. Type m -> Maybe (InterfaceType m)+isInterfaceType (NamedInterfaceType interfaceType) = Just interfaceType+isInterfaceType (NonNullInterfaceType interfaceType) = Just interfaceType+isInterfaceType _ = Nothing++isUnionType :: forall m. Type m -> Maybe (UnionType m)+isUnionType (NamedUnionType unionType) = Just unionType+isUnionType (NonNullUnionType unionType) = Just unionType+isUnionType _ = Nothing++isListType :: forall m. Type m -> Maybe (Type m)+isListType (ListType outputType) = Just outputType+isListType (NonNullListType outputType) = Just outputType+isListType _ = Nothing++-- | Checks whether the given output type is a non-null type.+isNonNullType :: forall m. Type m -> Bool+isNonNullType (NonNullScalarType _) = True+isNonNullType (NonNullEnumType _) = True+isNonNullType (NonNullObjectType _) = True+isNonNullType (NonNullInterfaceType _) = True+isNonNullType (NonNullUnionType _) = True+isNonNullType (NonNullListType _) = True+isNonNullType _ = False

@@ -0,0 +1,112 @@+{-# LANGUAGE ExplicitForAll #-}++-- | This module provides a representation of a @GraphQL@ Schema in addition to+-- functions for defining and manipulating schemas.+module Language.GraphQL.Type.Schema+    ( AbstractType(..)+    , CompositeType(..)+    , Schema(..)+    , Type(..)+    , collectReferencedTypes+    ) where++import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HashMap+import Language.GraphQL.AST.Document (Name)+import qualified Language.GraphQL.Type.Definition as Definition+import qualified Language.GraphQL.Type.In as In+import qualified Language.GraphQL.Type.Out as Out++-- | These are all of the possible kinds of types.+data Type m+    = ScalarType Definition.ScalarType+    | EnumType Definition.EnumType+    | ObjectType (Out.ObjectType m)+    | InputObjectType In.InputObjectType+    | InterfaceType (Out.InterfaceType m)+    | UnionType (Out.UnionType m)+    deriving Eq++-- | These types may describe the parent context of a selection set.+data CompositeType m+    = CompositeUnionType (Out.UnionType m)+    | CompositeObjectType (Out.ObjectType m)+    | CompositeInterfaceType (Out.InterfaceType m)+    deriving Eq++-- | These types may describe the parent context of a selection set.+data AbstractType m+    = AbstractUnionType (Out.UnionType m)+    | AbstractInterfaceType (Out.InterfaceType m)+    deriving Eq++-- | A Schema is created by supplying the root types of each type of operation,+--   query and mutation (optional). A schema definition is then supplied to the+--   validator and executor.+--+--   __Note:__ When the schema is constructed, by default only the types that+--   are reachable by traversing the root types are included, other types must+--   be explicitly referenced.+data Schema m = Schema+    { query :: Out.ObjectType m+    , mutation :: Maybe (Out.ObjectType m)+    }++-- | Traverses the schema and finds all referenced types.+collectReferencedTypes :: forall m. Schema m -> HashMap Name (Type m)+collectReferencedTypes schema =+    let queryTypes = traverseObjectType (query schema) HashMap.empty+     in maybe queryTypes (`traverseObjectType` queryTypes) $ mutation schema+  where+    collect traverser typeName element foundTypes+        | HashMap.member typeName foundTypes = foundTypes+        | otherwise = traverser $ HashMap.insert typeName element foundTypes+    visitFields (Out.Field _ outputType arguments) foundTypes+        = traverseOutputType outputType+        $ foldr visitArguments foundTypes arguments+    visitArguments (In.Argument _ inputType _) = traverseInputType inputType+    visitInputFields (In.InputField _ inputType _) = traverseInputType inputType+    traverseInputType (In.InputObjectBaseType objectType) =+        let (In.InputObjectType typeName _ inputFields) = objectType+            element = InputObjectType objectType+            traverser = flip (foldr visitInputFields) inputFields+         in collect traverser typeName element+    traverseInputType (In.ListBaseType listType) =+        traverseInputType listType+    traverseInputType (In.ScalarBaseType scalarType) =+        let (Definition.ScalarType typeName _) = scalarType+         in collect Prelude.id typeName (ScalarType scalarType)+    traverseInputType (In.EnumBaseType enumType) =+        let (Definition.EnumType typeName _ _) = enumType+         in collect Prelude.id typeName (EnumType enumType)+    traverseOutputType (Out.ObjectBaseType objectType) =+        traverseObjectType objectType+    traverseOutputType (Out.InterfaceBaseType interfaceType) =+        traverseInterfaceType interfaceType+    traverseOutputType (Out.UnionBaseType unionType) =+        let (Out.UnionType typeName _ types) = unionType+            traverser = flip (foldr traverseObjectType) types+         in collect traverser typeName (UnionType unionType)+    traverseOutputType (Out.ListBaseType listType) =+        traverseOutputType listType+    traverseOutputType (Out.ScalarBaseType scalarType) =+        let (Definition.ScalarType typeName _) = scalarType+         in collect Prelude.id typeName (ScalarType scalarType)+    traverseOutputType (Out.EnumBaseType enumType) =+        let (Definition.EnumType typeName _ _) = enumType+         in collect Prelude.id typeName (EnumType enumType)+    traverseObjectType objectType foundTypes =+        let (Out.ObjectType typeName _ interfaces resolvers) = objectType+            element = ObjectType objectType+            fields = extractObjectField <$> resolvers+            traverser = polymorphicTraverser interfaces fields+         in collect traverser typeName element foundTypes+    traverseInterfaceType interfaceType foundTypes =+        let (Out.InterfaceType typeName _ interfaces fields) = interfaceType+            element = InterfaceType interfaceType+            traverser = polymorphicTraverser interfaces fields+         in collect traverser typeName element foundTypes+    polymorphicTraverser interfaces fields+        = flip (foldr visitFields) fields+        . flip (foldr traverseInterfaceType) interfaces+    extractObjectField (Out.Resolver field _) = field

@@ -8,7 +8,7 @@ import Language.GraphQL.AST.Document import Language.GraphQL.AST.Parser import Test.Hspec (Spec, describe, it)-import Test.Hspec.Megaparsec (shouldParse, shouldSucceedOn)+import Test.Hspec.Megaparsec (shouldParse, shouldFailOn, shouldSucceedOn) import Text.Megaparsec (parse) import Text.RawString.QQ (r) @@ -140,5 +140,12 @@         parse document "" `shouldSucceedOn` [r|             extend type Story {               isHiddenLocally: Boolean+            }+        |]++    it "rejects variables in DefaultValue" $+        parse document "" `shouldFailOn` [r|+            query ($book: String = "Zarathustra", $author: String = $book) {+              title             }         |]

@@ -0,0 +1,122 @@+{-# LANGUAGE OverloadedStrings #-}+module Language.GraphQL.Execute.CoerceSpec+    ( spec+    ) where++import Data.Aeson as Aeson ((.=))+import qualified Data.Aeson as Aeson+import qualified Data.Aeson.Types as Aeson+import qualified Data.HashMap.Strict as HashMap+import Data.Maybe (isNothing)+import Data.Scientific (scientific)+import qualified Language.GraphQL.Execute.Coerce as Coerce+import Language.GraphQL.Type+import qualified Language.GraphQL.Type.In as In+import Prelude hiding (id)+import Test.Hspec (Spec, describe, it, shouldBe, shouldSatisfy)++direction :: EnumType+direction = EnumType "Direction" Nothing  $ HashMap.fromList+    [ ("NORTH", EnumValue Nothing)+    , ("EAST", EnumValue Nothing)+    , ("SOUTH", EnumValue Nothing)+    , ("WEST", EnumValue Nothing)+    ]++singletonInputObject :: In.Type+singletonInputObject = In.NamedInputObjectType type'+  where+    type' = In.InputObjectType "ObjectName" Nothing inputFields+    inputFields = HashMap.singleton "field" field+    field = In.InputField Nothing (In.NamedScalarType string) Nothing++namedIdType :: In.Type+namedIdType = In.NamedScalarType id++spec :: Spec+spec = do+    describe "VariableValue Aeson" $ do+        it "coerces strings" $+            let expected = Just (String "asdf")+                actual = Coerce.coerceVariableValue+                    (In.NamedScalarType string) (Aeson.String "asdf")+             in actual `shouldBe` expected+        it "coerces non-null strings" $+            let expected = Just (String "asdf")+                actual = Coerce.coerceVariableValue+                    (In.NonNullScalarType string) (Aeson.String "asdf")+             in actual `shouldBe` expected+        it "coerces booleans" $+            let expected = Just (Boolean True)+                actual = Coerce.coerceVariableValue+                    (In.NamedScalarType boolean) (Aeson.Bool True)+             in actual `shouldBe` expected+        it "coerces zero to an integer" $+            let expected = Just (Int 0)+                actual = Coerce.coerceVariableValue+                    (In.NamedScalarType int) (Aeson.Number 0)+             in actual `shouldBe` expected+        it "rejects fractional if an integer is expected" $+            let actual = Coerce.coerceVariableValue+                    (In.NamedScalarType int) (Aeson.Number $ scientific 14 (-1))+             in actual `shouldSatisfy` isNothing+        it "coerces float numbers" $+            let expected = Just (Float 1.4)+                actual = Coerce.coerceVariableValue+                    (In.NamedScalarType float) (Aeson.Number $ scientific 14 (-1))+             in actual `shouldBe` expected+        it "coerces IDs" $+            let expected = Just (String "1234")+                json = Aeson.String "1234"+                actual = Coerce.coerceVariableValue namedIdType json+             in actual `shouldBe` expected+        it "coerces input objects" $+            let actual = Coerce.coerceVariableValue singletonInputObject+                    $ Aeson.object ["field" .= ("asdf" :: Aeson.Value)]+                expected = Just $ Object $ HashMap.singleton "field" "asdf"+             in actual `shouldBe` expected+        it "skips the field if it is missing in the variables" $+            let actual = Coerce.coerceVariableValue+                    singletonInputObject Aeson.emptyObject+                expected = Just $ Object HashMap.empty+             in actual `shouldBe` expected+        it "fails if input object value contains extra fields" $+            let actual = Coerce.coerceVariableValue singletonInputObject+                    $ Aeson.object variableFields+                variableFields =+                    [ "field" .= ("asdf" :: Aeson.Value)+                    , "extra" .= ("qwer" :: Aeson.Value)+                    ]+             in actual `shouldSatisfy` isNothing+        it "preserves null" $+            let actual = Coerce.coerceVariableValue namedIdType Aeson.Null+             in actual `shouldBe` Just Null+        it "preserves list order" $+            let list = Aeson.toJSONList ["asdf" :: Aeson.Value, "qwer"]+                listType = (In.ListType $ In.NamedScalarType string)+                actual = Coerce.coerceVariableValue listType list+                expected = Just $ List [String "asdf", String "qwer"]+             in actual `shouldBe` expected++    describe "coerceInputLiteral" $ do+        it "coerces enums" $+            let expected = Just (Enum "NORTH")+                actual = Coerce.coerceInputLiteral+                    (In.NamedEnumType direction) (Enum "NORTH")+             in actual `shouldBe` expected+        it "fails with non-existing enum value" $+            let actual = Coerce.coerceInputLiteral+                    (In.NamedEnumType direction) (Enum "NORTH_EAST")+             in actual `shouldSatisfy` isNothing+        it "coerces integers to IDs" $+            let expected = Just (String "1234")+                actual = Coerce.coerceInputLiteral namedIdType (Int 1234)+             in actual `shouldBe` expected+        it "coerces nulls" $ do+            let actual = Coerce.coerceInputLiteral namedIdType Null+             in actual `shouldBe` Just Null+        it "wraps singleton lists" $ do+            let expected = Just $ List [List [String "1"]]+                embeddedType = In.ListType $ In.ListType namedIdType+                actual = Coerce.coerceInputLiteral embeddedType (String "1")+             in actual `shouldBe` expected

@@ -0,0 +1,75 @@+{-# LANGUAGE OverloadedStrings #-}+module Language.GraphQL.ExecuteSpec+    ( spec+    ) where++import Data.Aeson ((.=))+import qualified Data.Aeson as Aeson+import Data.Functor.Identity (Identity(..))+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HashMap+import Language.GraphQL.AST (Name)+import Language.GraphQL.AST.Parser (document)+import Language.GraphQL.Error+import Language.GraphQL.Execute+import Language.GraphQL.Type as Type+import Language.GraphQL.Type.Out as Out+import Test.Hspec (Spec, describe, it, shouldBe)+import Text.Megaparsec (parse)++schema :: Schema Identity+schema = Schema {query = queryType, mutation = Nothing}++queryType :: Out.ObjectType Identity+queryType = Out.ObjectType "Query" Nothing []+    $ HashMap.singleton "philosopher"+    $ Out.Resolver philosopherField+    $ pure+    $ Type.Object mempty+  where+    philosopherField =+        Out.Field Nothing (Out.NonNullObjectType philosopherType) HashMap.empty++philosopherType :: Out.ObjectType Identity+philosopherType = Out.ObjectType "Philosopher" Nothing []+    $ HashMap.fromList resolvers+  where+    resolvers =+        [ ("firstName", firstNameResolver)+        , ("lastName", lastNameResolver)+        ]+    firstNameResolver = Out.Resolver firstNameField $ pure $ Type.String "Friedrich"+    lastNameResolver = Out.Resolver lastNameField $ pure $ Type.String "Nietzsche"+    firstNameField = Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty+    lastNameField = Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty++spec :: Spec+spec =+    describe "execute" $ do+        it "skips unknown fields" $+            let expected = Aeson.object+                    [ "data" .= Aeson.object+                        [ "philosopher" .= Aeson.object+                            [ "firstName" .= ("Friedrich" :: String)+                            ]+                        ]+                    ]+                execute' = execute schema (mempty :: HashMap Name Aeson.Value)+                actual = runIdentity+                    $ either parseError execute'+                    $ parse document "" "{ philosopher { firstName surname } }"+             in actual `shouldBe` expected+        it "merges selections" $+            let expected = Aeson.object+                    [ "data" .= Aeson.object+                        [ "philosopher" .= Aeson.object+                            [ "firstName" .= ("Friedrich" :: String)+                            , "lastName" .= ("Nietzsche" :: String)+                            ]+                        ]+                    ]+                execute' = execute schema (mempty :: HashMap Name Aeson.Value)+                actual = runIdentity+                    $ either parseError execute'+                    $ parse document "" "{ philosopher { firstName } philosopher { lastName } }"+             in actual `shouldBe` expected

@@ -0,0 +1,14 @@+{-# LANGUAGE OverloadedStrings #-}+module Language.GraphQL.Type.OutSpec+    ( spec+    ) where++import Language.GraphQL.Type+import Test.Hspec (Spec, describe, it, shouldBe)++spec :: Spec+spec =+    describe "Value" $+        it "supports overloaded strings" $+            let nietzsche = "Goldstaub abblasen." :: Value+             in nietzsche `shouldBe` String "Goldstaub abblasen."

@@ -4,21 +4,24 @@     ( spec     ) where -import Data.Aeson (Value, object, (.=))-import Data.HashMap.Strict (HashMap)+import Data.Aeson (object, (.=))+import qualified Data.Aeson as Aeson import qualified Data.HashMap.Strict as HashMap-import Data.List.NonEmpty (NonEmpty(..))-import Data.Text (Text) import Language.GraphQL-import qualified Language.GraphQL.Schema as Schema+import Language.GraphQL.Type+import qualified Language.GraphQL.Type.Out as Out import Test.Hspec (Spec, describe, it, shouldBe) import Text.RawString.QQ (r) -experimentalResolver :: HashMap Text (NonEmpty (Schema.Resolver IO))-experimentalResolver = HashMap.singleton "Query"-    $ Schema.scalar "experimentalField" (pure (5 :: Int)) :| []+experimentalResolver :: Schema IO+experimentalResolver = Schema { query = queryType, mutation = Nothing }+  where+    resolver = pure $ Int 5+    queryType = Out.ObjectType "Query" Nothing []+        $ HashMap.singleton "experimentalField"+        $ Out.Resolver (Out.Field Nothing (Out.NamedScalarType int) mempty) resolver -emptyObject :: Value+emptyObject :: Aeson.Value emptyObject = object     [ "data" .= object []     ]@@ -27,17 +30,17 @@ spec =     describe "Directive executor" $ do         it "should be able to @skip fields" $ do-            let query = [r|+            let sourceQuery = [r|               {                 experimentalField @skip(if: true)               }             |] -            actual <- graphql experimentalResolver query+            actual <- graphql experimentalResolver sourceQuery             actual `shouldBe` emptyObject          it "should not skip fields if @skip is false" $ do-            let query = [r|+            let sourceQuery = [r|               {                 experimentalField @skip(if: false)               }@@ -48,21 +51,21 @@                         ]                     ] -            actual <- graphql experimentalResolver query+            actual <- graphql experimentalResolver sourceQuery             actual `shouldBe` expected          it "should skip fields if @include is false" $ do-            let query = [r|+            let sourceQuery = [r|               {                 experimentalField @include(if: false)               }             |] -            actual <- graphql experimentalResolver query+            actual <- graphql experimentalResolver sourceQuery             actual `shouldBe` emptyObject          it "should be able to @skip a fragment spread" $ do-            let query = [r|+            let sourceQuery = [r|               {                 ...experimentalFragment @skip(if: true)               }@@ -72,11 +75,11 @@               }             |] -            actual <- graphql experimentalResolver query+            actual <- graphql experimentalResolver sourceQuery             actual `shouldBe` emptyObject          it "should be able to @skip an inline fragment" $ do-            let query = [r|+            let sourceQuery = [r|               {                 ... on ExperimentalType @skip(if: true) {                   experimentalField@@ -84,5 +87,5 @@               }             |] -            actual <- graphql experimentalResolver query+            actual <- graphql experimentalResolver sourceQuery             actual `shouldBe` emptyObject

@@ -4,32 +4,35 @@     ( spec     ) where -import Data.Aeson (Value(..), object, (.=))+import Data.Aeson (object, (.=))+import qualified Data.Aeson as Aeson import qualified Data.HashMap.Strict as HashMap-import Data.List.NonEmpty (NonEmpty(..)) import Data.Text (Text) import Language.GraphQL-import qualified Language.GraphQL.Schema as Schema-import Test.Hspec ( Spec-                  , describe-                  , it-                  , shouldBe-                  , shouldSatisfy-                  , shouldNotSatisfy-                  )+import Language.GraphQL.Type+import qualified Language.GraphQL.Type.Out as Out+import Test.Hspec+    ( Spec+    , describe+    , it+    , shouldBe+    , shouldNotSatisfy+    ) import Text.RawString.QQ (r) -size :: Schema.Resolver IO-size = Schema.scalar "size" $ return ("L" :: Text)+size :: (Text, Value)+size = ("size", String "L") -circumference :: Schema.Resolver IO-circumference = Schema.scalar "circumference" $ return (60 :: Int)+circumference :: (Text, Value)+circumference = ("circumference", Int 60) -garment :: Text -> Schema.Resolver IO-garment typeName = Schema.object "garment" $ return-    [ if typeName == "Hat" then circumference else size-    , Schema.scalar "__typename" $ return typeName-    ]+garment :: Text -> (Text, Value)+garment typeName =+    ("garment",  Object $ HashMap.fromList+        [ if typeName == "Hat" then circumference else size+        , ("__typename", String typeName)+        ]+    )  inlineQuery :: Text inlineQuery = [r|{@@ -43,15 +46,52 @@   } }|] -hasErrors :: Value -> Bool-hasErrors (Object object') = HashMap.member "errors" object'+hasErrors :: Aeson.Value -> Bool+hasErrors (Aeson.Object object') = HashMap.member "errors" object' hasErrors _ = True +shirtType :: Out.ObjectType IO+shirtType = Out.ObjectType "Shirt" Nothing []+    $ HashMap.fromList+        [ ("size", Out.Resolver sizeFieldType $ pure $ snd size)+        , ("circumference", Out.Resolver circumferenceFieldType $ pure $ snd circumference)+        ]++hatType :: Out.ObjectType IO+hatType = Out.ObjectType "Hat" Nothing []+    $ HashMap.fromList+        [ ("size", Out.Resolver sizeFieldType $ pure $ snd size)+        , ("circumference", Out.Resolver circumferenceFieldType $ pure $ snd circumference)+        ]++circumferenceFieldType :: Out.Field IO+circumferenceFieldType = Out.Field Nothing (Out.NamedScalarType int) mempty++sizeFieldType :: Out.Field IO+sizeFieldType = Out.Field Nothing (Out.NamedScalarType string) mempty++toSchema :: Text -> (Text, Value) -> Schema IO+toSchema t (_, resolve) = Schema+    { query = queryType, mutation = Nothing }+  where+    unionMember = if t == "Hat" then hatType else shirtType+    typeNameField = Out.Field Nothing (Out.NamedScalarType string) mempty+    garmentField = Out.Field Nothing (Out.NamedObjectType unionMember) mempty+    queryType =+        case t of+            "circumference" -> hatType+            "size" -> shirtType+            _ -> Out.ObjectType "Query" Nothing []+                $ HashMap.fromList+                    [ ("garment", Out.Resolver garmentField $ pure resolve)+                    , ("__typename", Out.Resolver typeNameField $ pure $ String "Shirt")+                    ]+ spec :: Spec spec = do     describe "Inline fragment executor" $ do         it "chooses the first selection if the type matches" $ do-            actual <- graphql (HashMap.singleton "Query" $ garment "Hat" :| []) inlineQuery+            actual <- graphql (toSchema "Hat" $ garment "Hat") inlineQuery             let expected = object                     [ "data" .= object                         [ "garment" .= object@@ -62,7 +102,7 @@              in actual `shouldBe` expected          it "chooses the last selection if the type matches" $ do-            actual <- graphql (HashMap.singleton "Query" $ garment "Shirt" :| []) inlineQuery+            actual <- graphql (toSchema "Shirt" $ garment "Shirt") inlineQuery             let expected = object                     [ "data" .= object                         [ "garment" .= object@@ -73,7 +113,7 @@              in actual `shouldBe` expected          it "embeds inline fragments without type" $ do-            let query = [r|{+            let sourceQuery = [r|{               garment {                 circumference                 ... {@@ -81,9 +121,9 @@                 }               }             }|]-                resolvers = Schema.object "garment" $ return [circumference,  size]+                resolvers = ("garment", Object $ HashMap.fromList [circumference,  size]) -            actual <- graphql (HashMap.singleton "Query" $ resolvers :| []) query+            actual <- graphql (toSchema "garment" resolvers) sourceQuery             let expected = object                     [ "data" .= object                         [ "garment" .= object@@ -95,18 +135,18 @@              in actual `shouldBe` expected          it "evaluates fragments on Query" $ do-            let query = [r|{+            let sourceQuery = [r|{               ... {                 size               }             }|] -            actual <- graphql (HashMap.singleton "Query" $ size :| []) query+            actual <- graphql (toSchema "size" size) sourceQuery             actual `shouldNotSatisfy` hasErrors      describe "Fragment spread executor" $ do         it "evaluates fragment spreads" $ do-            let query = [r|+            let sourceQuery = [r|               {                 ...circumferenceFragment               }@@ -116,7 +156,7 @@               }             |] -            actual <- graphql (HashMap.singleton "Query" $ circumference :| []) query+            actual <- graphql (toSchema "circumference" circumference) sourceQuery             let expected = object                     [ "data" .= object                         [ "circumference" .= (60 :: Int)@@ -125,7 +165,7 @@              in actual `shouldBe` expected          it "evaluates nested fragments" $ do-            let query = [r|+            let sourceQuery = [r|               {                 garment {                   ...circumferenceFragment@@ -141,7 +181,7 @@               }             |] -            actual <- graphql (HashMap.singleton "Query" $ garment "Hat" :| []) query+            actual <- graphql (toSchema "Hat" $ garment "Hat") sourceQuery             let expected = object                     [ "data" .= object                         [ "garment" .= object@@ -152,7 +192,10 @@              in actual `shouldBe` expected          it "rejects recursive fragments" $ do-            let query = [r|+            let expected = object+                    [ "data" .= object []+                    ]+                sourceQuery = [r|               {                 ...circumferenceFragment               }@@ -162,11 +205,11 @@               }             |] -            actual <- graphql (HashMap.singleton "Query" $ circumference :| []) query-            actual `shouldSatisfy` hasErrors+            actual <- graphql (toSchema "circumference" circumference) sourceQuery+            actual `shouldBe` expected          it "considers type condition" $ do-            let query = [r|+            let sourceQuery = [r|               {                 garment {                   ...circumferenceFragment@@ -187,5 +230,5 @@                             ]                         ]                     ]-            actual <- graphql (HashMap.singleton "Query" $ garment "Hat" :| []) query+            actual <- graphql (toSchema "Hat" $ garment "Hat") sourceQuery             actual `shouldBe` expected

@@ -0,0 +1,68 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+module Test.RootOperationSpec+    ( spec+    ) where++import Data.Aeson ((.=), object)+import qualified Data.HashMap.Strict as HashMap+import Language.GraphQL+import Test.Hspec (Spec, describe, it, shouldBe)+import Text.RawString.QQ (r)+import Language.GraphQL.Type+import qualified Language.GraphQL.Type.Out as Out++hatType :: Out.ObjectType IO+hatType = Out.ObjectType "Hat" Nothing []+    $ HashMap.singleton "circumference"+    $ Out.Resolver (Out.Field Nothing (Out.NamedScalarType int) mempty)+    $ pure $ Int 60++schema :: Schema IO+schema = Schema+    (Out.ObjectType "Query" Nothing [] hatField)+    (Just $ Out.ObjectType "Mutation" Nothing [] incrementField)+  where+    garment = pure $ Object $ HashMap.fromList+        [ ("circumference", Int 60)+        ]+    incrementField = HashMap.singleton "incrementCircumference"+        $ Out.Resolver (Out.Field Nothing (Out.NamedScalarType int) mempty)+        $ pure $ Int 61+    hatField = HashMap.singleton "garment"+        $ Out.Resolver (Out.Field Nothing (Out.NamedObjectType hatType) mempty) garment++spec :: Spec+spec =+    describe "Root operation type" $ do+        it "returns objects from the root resolvers" $ do+            let querySource = [r|+              {+                garment {+                  circumference+                }+              }+            |]+                expected = object+                    [ "data" .= object+                        [ "garment" .= object+                            [ "circumference" .= (60 :: Int)+                            ]+                        ]+                    ]+            actual <- graphql schema querySource+            actual `shouldBe` expected++        it "chooses Mutation" $ do+            let querySource = [r|+              mutation {+                incrementCircumference+              }+            |]+                expected = object+                    [ "data" .= object+                        [ "incrementCircumference" .= (61 :: Int)+                        ]+                    ]+            actual <- graphql schema querySource+            actual `shouldBe` expected

@@ -11,7 +11,7 @@     , getHuman     , id_     , homePlanet-    , name+    , name_     , secretBackstory     , typeName     ) where@@ -22,7 +22,6 @@ import Data.Maybe (catMaybes) import Data.Text (Text) import Language.GraphQL.Trans-import qualified Language.GraphQL.Type as Type  -- * Data -- See https://github.com/graphql/graphql-js/blob/master/src/__tests__/starWarsData.js@@ -55,9 +54,9 @@ 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+name_ :: Character -> Text+name_ (Left  x) = _name . _droidChar $ x+name_ (Right x) = _name . _humanChar $ x  friends :: Character -> [ID] friends (Left  x) = _friends . _droidChar $ x@@ -67,8 +66,8 @@ appearsIn (Left  x) = _appearsIn . _droidChar $ x appearsIn (Right x) = _appearsIn . _humanChar $ x -secretBackstory :: Character -> ActionT Identity Text-secretBackstory = const $ ActionT $ throwE "secretBackstory is secret."+secretBackstory :: ActionT Identity Text+secretBackstory = ActionT $ throwE "secretBackstory is secret."  typeName :: Character -> Text typeName = either (const "Droid") (const "Human")@@ -184,8 +183,8 @@ getFriends :: Character -> [Character] getFriends char = catMaybes $ liftA2 (<|>) getDroid getHuman <$> friends char -getEpisode :: Int -> Maybe (Type.Wrapping Text)-getEpisode 4 = pure $ Type.Named "NEWHOPE"-getEpisode 5 = pure $ Type.Named "EMPIRE"-getEpisode 6 = pure $ Type.Named "JEDI"+getEpisode :: Int -> Maybe Text+getEpisode 4 = pure "NEW_HOPE"+getEpisode 5 = pure "EMPIRE"+getEpisode 6 = pure "JEDI" getEpisode _ = empty

@@ -10,7 +10,6 @@ import qualified Data.HashMap.Strict as HashMap import Data.Text (Text) import Language.GraphQL-import Language.GraphQL.Schema (Subs) import Text.RawString.QQ (r) import Test.Hspec.Expectations (Expectation, shouldBe) import Test.Hspec (Spec, describe, it)@@ -40,7 +39,7 @@                 id                 name                 friends {-                name+                  name                 }             }             }@@ -65,9 +64,9 @@                 friends {                   name                   appearsIn-                    friends {-                      name-                    }+                  friends {+                    name+                  }                 }               }             }@@ -78,7 +77,7 @@             , "friends" .= [                   Aeson.object [                       "name" .= ("Luke Skywalker" :: Text)-                    , "appearsIn" .= ["NEWHOPE","EMPIRE","JEDI" :: Text]+                    , "appearsIn" .= ["NEW_HOPE", "EMPIRE", "JEDI" :: Text]                     , "friends" .= [                           Aeson.object [hanName]                         , Aeson.object [leiaName]@@ -88,7 +87,7 @@                     ]                 , Aeson.object [                       hanName-                    , "appearsIn" .= [ "NEWHOPE","EMPIRE","JEDI" :: Text]+                    , "appearsIn" .= ["NEW_HOPE", "EMPIRE", "JEDI" :: Text]                     , "friends" .=                         [ Aeson.object [lukeName]                         , Aeson.object [leiaName]@@ -97,7 +96,7 @@                     ]                 , Aeson.object [                       leiaName-                    , "appearsIn" .= [ "NEWHOPE","EMPIRE","JEDI" :: Text]+                    , "appearsIn" .= ["NEW_HOPE", "EMPIRE", "JEDI" :: Text]                     , "friends" .=                         [ Aeson.object [lukeName]                         , Aeson.object [hanName]@@ -360,6 +359,6 @@ testQuery :: Text -> Aeson.Value -> Expectation testQuery q expected = runIdentity (graphql schema q) `shouldBe` expected -testQueryParams :: Subs -> Text -> Aeson.Value -> Expectation+testQueryParams :: Aeson.Object -> Text -> Aeson.Value -> Expectation testQueryParams f q expected =     runIdentity (graphqlSubs schema f q) `shouldBe` expected

@@ -1,66 +1,133 @@ {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-} module Test.StarWars.Schema-    ( character-    , droid-    , hero-    , human-    , schema+    ( schema     ) where +import Control.Monad.Trans.Reader (asks) import Control.Monad.Trans.Except (throwE) import Control.Monad.Trans.Class (lift) import Data.Functor.Identity (Identity)-import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap-import Data.List.NonEmpty (NonEmpty(..)) import Data.Maybe (catMaybes) import Data.Text (Text)-import qualified Language.GraphQL.Schema as Schema import Language.GraphQL.Trans-import qualified Language.GraphQL.Type as Type+import Language.GraphQL.Type+import qualified Language.GraphQL.Type.In as In+import qualified Language.GraphQL.Type.Out as Out import Test.StarWars.Data+import Prelude hiding (id)  -- See https://github.com/graphql/graphql-js/blob/master/src/__tests__/starWarsSchema.js -schema :: HashMap Text (NonEmpty (Schema.Resolver Identity))-schema = HashMap.singleton "Query" $ hero :| [human, droid]+schema :: Schema Identity+schema = Schema { query = queryType, mutation = Nothing }+  where+    queryType = Out.ObjectType "Query" Nothing [] $ HashMap.fromList+        [ ("hero", Out.Resolver heroField hero)+        , ("human", Out.Resolver humanField human)+        , ("droid", Out.Resolver droidField droid)+        ]+    heroField = Out.Field Nothing (Out.NamedObjectType heroObject)+        $ HashMap.singleton "episode"+        $ In.Argument Nothing (In.NamedEnumType episodeEnum) Nothing+    humanField = Out.Field Nothing (Out.NamedObjectType heroObject)+        $ HashMap.singleton "id"+        $ In.Argument Nothing (In.NonNullScalarType string) Nothing+    droidField = Out.Field Nothing (Out.NamedObjectType droidObject) mempty -hero :: Schema.Resolver Identity-hero = Schema.object "hero" $ do+heroObject :: Out.ObjectType Identity+heroObject = Out.ObjectType "Human" Nothing [] $ HashMap.fromList+    [ ("id", Out.Resolver idFieldType (idField "id"))+    , ("name", Out.Resolver nameFieldType (idField "name"))+    , ("friends", Out.Resolver friendsFieldType (idField "friends"))+    , ("appearsIn", Out.Resolver appearsInField (idField "appearsIn"))+    , ("homePlanet", Out.Resolver homePlanetFieldType (idField "homePlanet"))+    , ("secretBackstory", Out.Resolver secretBackstoryFieldType (String <$> secretBackstory))+    , ("__typename", Out.Resolver (Out.Field Nothing (Out.NamedScalarType string) mempty) (idField "__typename"))+    ]+  where+    homePlanetFieldType = Out.Field Nothing (Out.NamedScalarType string) mempty++droidObject :: Out.ObjectType Identity+droidObject = Out.ObjectType "Droid" Nothing [] $ HashMap.fromList+    [ ("id", Out.Resolver idFieldType (idField "id"))+    , ("name", Out.Resolver nameFieldType (idField "name"))+    , ("friends", Out.Resolver friendsFieldType (idField "friends"))+    , ("appearsIn", Out.Resolver appearsInField (idField "appearsIn"))+    , ("primaryFunction", Out.Resolver primaryFunctionFieldType (idField "primaryFunction"))+    , ("secretBackstory", Out.Resolver secretBackstoryFieldType (String <$> secretBackstory))+    , ("__typename", Out.Resolver (Out.Field Nothing (Out.NamedScalarType string) mempty) (idField "__typename"))+    ]+  where+    primaryFunctionFieldType = Out.Field Nothing (Out.NamedScalarType string) mempty++idFieldType :: Out.Field Identity+idFieldType = Out.Field Nothing (Out.NamedScalarType id) mempty++nameFieldType :: Out.Field Identity+nameFieldType = Out.Field Nothing (Out.NamedScalarType string) mempty++friendsFieldType :: Out.Field Identity+friendsFieldType = Out.Field Nothing (Out.ListType $ Out.NamedObjectType droidObject) mempty++appearsInField :: Out.Field Identity+appearsInField = Out.Field (Just description) fieldType mempty+  where+    fieldType = Out.ListType $ Out.NamedEnumType episodeEnum+    description = "Which movies they appear in."++secretBackstoryFieldType :: Out.Field Identity+secretBackstoryFieldType = Out.Field Nothing (Out.NamedScalarType string) mempty++idField :: Text -> ActionT Identity Value+idField f = do+    v <- ActionT $ lift $ asks values+    let (Object v') = v+    pure $ v' HashMap.! f++episodeEnum :: EnumType+episodeEnum = EnumType "Episode" (Just description)+    $ HashMap.fromList [newHope, empire, jedi]+  where+    description = "One of the films in the Star Wars Trilogy"+    newHope = ("NEW_HOPE", EnumValue $ Just "Released in 1977.")+    empire = ("EMPIRE", EnumValue $ Just "Released in 1980.")+    jedi = ("JEDI", EnumValue $ Just "Released in 1983.")++hero :: ActionT Identity Value+hero = do   episode <- argument "episode"-  character $ case episode of-      Schema.Enum "NEWHOPE" -> getHero 4-      Schema.Enum "EMPIRE" -> getHero 5-      Schema.Enum "JEDI" -> getHero 6+  pure $ character $ case episode of+      Enum "NEW_HOPE" -> getHero 4+      Enum "EMPIRE" -> getHero 5+      Enum "JEDI" -> getHero 6       _ -> artoo -human :: Schema.Resolver Identity-human = Schema.wrappedObject "human" $ do+human :: ActionT Identity Value+human = do     id' <- argument "id"     case id' of-        Schema.String i -> do+        String i -> do             humanCharacter <- lift $ return $ getHuman i >>= Just             case humanCharacter of-                Nothing -> return Type.Null-                Just e -> Type.Named <$> character e+                Nothing -> pure Null+                Just e -> pure $ character e         _ -> ActionT $ throwE "Invalid arguments." -droid :: Schema.Resolver Identity-droid = Schema.object "droid" $ do+droid :: ActionT Identity Value+droid = do     id' <- argument "id"     case id' of-        Schema.String i -> character =<< getDroid i+        String i -> character <$> getDroid i         _ -> ActionT $ throwE "Invalid arguments." -character :: Character -> ActionT Identity [Schema.Resolver Identity]-character char = return-    [ Schema.scalar "id" $ return $ id_ char-    , Schema.scalar "name" $ return $ name char-    , Schema.wrappedObject "friends"-        $ traverse character $ Type.List $ Type.Named <$> getFriends char-    , Schema.wrappedScalar "appearsIn" $ return . Type.List-        $ catMaybes (getEpisode <$> appearsIn char)-    , Schema.scalar "secretBackstory" $ secretBackstory char-    , Schema.scalar "homePlanet" $ return $ either mempty homePlanet char-    , Schema.scalar "__typename" $ return $ typeName char+character :: Character -> Value+character char = Object $ HashMap.fromList+    [ ("id", String $ id_ char)+    , ("name", String $ name_ char)+    , ("friends", List $ character <$> getFriends char)+    , ("appearsIn", List $ Enum <$> catMaybes (getEpisode <$> appearsIn char))+    , ("homePlanet", String $ either mempty homePlanet char)+    , ("__typename", String $ typeName char)     ]