Release 0.10.0.0

Fixes #52.

CHANGELOG.md

@@ -6,7 +6,20 @@ The format is based on
 and this project adheres to
 [Haskell Package Versioning Policy](https://pvp.haskell.org/).
 
-## [Unreleased]
+## [0.10.0.0] - 2020-08-29
+## Changed
+- `Test.Hspec.GraphQL.*`: replace `IO` in the resolver with any `MonadCatch`.
+- The `Location` argument of `AST.Document.Definition.ExecutableDefinition` was
+  moved to `OperationDefinition` and `FragmentDefinition` since these are the
+  actual elements that have a location in the document.
+- `Validate.Rules` get the whole validation context (AST and schema).
+
+## Added
+- `Validate.Validation` contains data structures and functions used by the
+  validator and concretet rules.
+- `Validate.Rules`: operation validation rules.
+
+## [0.9.0.0] - 2020-07-24
 ## Fixed
 - Location of a parse error is returned in a singleton array with key
   `locations`.
@@ -21,13 +34,14 @@ and this project adheres to
 - `Error.Error` is an error representation with a message and source location.
 - `Error.Response` represents a result of running a GraphQL query.
 - `Type.Schema` exports `Type` which lists all types possible in the schema.
-- Parsing subscriptions (the execution always fails yet).
+- Parsing subscriptions.
 - `Error.ResponseEventStream`, `Type.Out.Resolve`, `Type.Out.Subscribe` and
   `Type.Out.SourceEventStream` define subscription resolvers.
 - `Error.ResolverException` is an exception that can be thrown by (field value
   and event stream) resolvers to signalize an error. Other exceptions will
   escape.
 - `Test.Hspec.GraphQL` contains some test helpers.
+- `Validate` contains the validator and standard rules.
 
 ## Changed
 - `Type.Out.Resolver`: Interface fields don't have resolvers, object fields
@@ -56,8 +70,6 @@ and this project adheres to
 ## Removed
 - `Trans.ActionT` is an unneeded layer of complexity. `Type.Out.Resolver`
   represents possible resolver configurations.
-- `Type.Out.Resolver`: It . Resolvers are a
-  part of the fields and are called `Trans.ResolverT`.
 - `Execute.executeWithName`. `Execute.execute` takes the operation name and
    completely replaces `executeWithName`.
 
@@ -322,7 +334,8 @@ and this project adheres to
 ### Added
 - Data types for the GraphQL language.
 
-[Unreleased]: https://github.com/caraus-ecms/graphql/compare/v0.8.0.0...HEAD
+[0.10.0.0]: https://github.com/caraus-ecms/graphql/compare/v0.9.0.0...v0.10.0.0
+[0.9.0.0]: https://github.com/caraus-ecms/graphql/compare/v0.8.0.0...v0.9.0.0
 [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

README.md

@@ -1,10 +1,9 @@
-# Haskell GraphQL
+# GraphQL implementation in Haskell
 
 [![Hackage Version](https://img.shields.io/hackage/v/graphql.svg)](https://hackage.haskell.org/package/graphql)
 [![Build Status](https://github.com/caraus-ecms/graphql/workflows/Haskell%20CI/badge.svg)](https://github.com/caraus-ecms/graphql/actions?query=workflow%3A%22Haskell+CI%22)
 [![License](https://img.shields.io/badge/license-BSD--3--Clause-blue.svg)](https://raw.githubusercontent.com/caraus-ecms/graphql/master/LICENSE)
-
-GraphQL implementation in Haskell.
+[![Simple Haskell](https://www.simplehaskell.org/badges/badge.svg)](https://www.simplehaskell.org)
 
 This implementation is relatively low-level by design, it doesn't provide any
 mappings between the GraphQL types and Haskell's type system and avoids
@@ -13,12 +12,19 @@ be built on top of it.
 
 ## State of the work
 
-For now this only provides a parser and a printer for the GraphQL query language
-and allows to execute queries and mutations using the given schema, but without
-the validation step. But the idea is to be a Haskell port of
+For now this library provides:
+
+- Parser for the query and schema languages, as well as a printer for the query
+  language (minimizer and pretty-printer).
+- Data structures to define a type system.
+- Executor (queries, mutations and subscriptions are supported).
+- Validation is work in progress.
+- Introspection isn't available yet.
+
+But the idea is to be a Haskell port of
 [`graphql-js`](https://github.com/graphql/graphql-js).
 
-For the list of currently missing features see issues marked as
+For a more precise list of currently missing features see issues marked as
 "[not implemented](https://github.com/caraus-ecms/graphql/labels/not%20implemented)".
 
 ## Documentation
@@ -29,6 +35,100 @@ API documentation is available through
 You'll also find a small tutorial with some examples under
 [docs/tutorial](https://github.com/caraus-ecms/graphql/tree/master/docs/tutorial).
 
+### Getting started
+
+We start with a simple GraphQL API that provides us with some famous and less
+famous cites.
+
+```graphql
+"""
+Root Query type.
+"""
+type Query {
+  """
+  Provides a cite.
+  """
+  cite: String!
+}
+```
+
+This is called a GraphQL schema, it defines all queries supported by the API.
+`Query` is the root query type. Every GraphQL API should define a query type.
+
+`Query` has a single field `cite` that returns a `String`. The `!` after the
+type denotes that the returned value cannot be `Null`. GraphQL fields are
+nullable by default.
+
+To be able to work with this schema, we are going to implement it in Haskell.
+
+```haskell
+{-# LANGUAGE OverloadedStrings #-}
+
+import Control.Exception (SomeException)
+import qualified Data.Aeson as Aeson
+import qualified Data.ByteString.Lazy.Char8 as ByteString.Lazy.Char8
+import qualified Data.HashMap.Strict as HashMap
+import Language.GraphQL
+import Language.GraphQL.Type
+import qualified Language.GraphQL.Type.Out as Out
+
+-- GraphQL supports 3 kinds of operations: queries, mutations and subscriptions.
+-- Our first schema supports only queries.
+schema :: Schema IO
+schema = Schema
+    { query = queryType, mutation = Nothing, subscription = Nothing }
+
+-- GraphQL distinguishes between input and output types. Input types are field
+-- argument types and they are defined in Language.GraphQL.Type.In. Output types
+-- are result types, they are defined in Language.GraphQL.Type.Out. Root types
+-- are always object types.
+--
+-- Here we define a type "Query". The second argument is an optional
+-- description, the third one is the list of interfaces implemented by the
+-- object type. The last argument is a field map. Keys are field names, values
+-- are field definitions and resolvers. Resolvers are the functions, where the
+-- actual logic lives, they return values for the respective fields.
+queryType :: Out.ObjectType IO
+queryType = Out.ObjectType "Query" (Just "Root Query type.") []
+    $ HashMap.singleton "cite" citeResolver
+  where
+    -- 'ValueResolver' is a 'Resolver' data constructor, it combines a field
+    -- definition with its resolver function. This function resolves a value for
+    -- a field (as opposed to the 'EventStreamResolver' used by subscriptions).
+    -- Our resolver just returns a constant value.
+    citeResolver = ValueResolver citeField
+        $ pure "Piscis primum a capite foetat"
+    -- The first argument is an optional field description. The second one is
+    -- the field type and the third one is for arguments (we have none in this
+    -- example).
+    --
+    -- GraphQL has named and wrapping types. String is a scalar, named type.
+    -- Named types are nullable by default. To make our "cite" field
+    -- non-nullable, we wrap it in the wrapping type, Non-Null.
+    citeField = Out.Field
+        (Just "Provides a cite.") (Out.NonNullScalarType string) HashMap.empty
+
+-- Now we can execute a query. Since our schema defines only one field,
+-- everything we can do is to ask to resolve it and give back the result.
+-- Since subscriptions don't return plain values, the 'graphql' function returns
+-- an 'Either'. 'Left' is for subscriptions, 'Right' is for queries and
+-- mutations.
+main :: IO ()
+main = do
+    Right result <- graphql schema "{ cite }"
+    ByteString.Lazy.Char8.putStrLn $ Aeson.encode result
+```
+
+Executing this query produces the following JSON:
+
+```json
+{
+  "data": {
+    "cite": "Piscis primum a capite foetat"
+  }
+}
+```
+
 ## Further information
 
 - [Contributing guidelines](CONTRIBUTING.md).

graphql.cabal

@@ -4,10 +4,10 @@ cabal-version: 1.12
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: ba234bcfff46df053a3466359e32682c4592b88894911ecbe78bd00fa00929b5
+-- hash: 3ef060c57424074b84204bae61ee0a63e3470a7a060c45a977ff2bcbe4df8775
 
 name:           graphql
-version:        0.8.0.0
+version:        0.10.0.0
 synopsis:       Haskell GraphQL implementation
 description:    This package provides a rudimentary parser for the <https://graphql.github.io/graphql-spec/June2018/ GraphQL> language.
 category:       Language
@@ -24,12 +24,10 @@ license-file:   LICENSE
 build-type:     Simple
 extra-source-files:
     CHANGELOG.md
-    README.md
+    CONTRIBUTING.md
     LICENSE
+    README.md
     docs/tutorial/tutorial.lhs
-data-files:
-    tests/data/kitchen-sink.graphql
-    tests/data/kitchen-sink.min.graphql
 
 source-repository head
   type: git
@@ -52,6 +50,7 @@ library
       Language.GraphQL.Type.Out
       Language.GraphQL.Type.Schema
       Language.GraphQL.Validate
+      Language.GraphQL.Validate.Validation
       Test.Hspec.GraphQL
   other-modules:
       Language.GraphQL.Execute.Execution
@@ -91,7 +90,6 @@ test-suite tasty
       Language.GraphQL.ValidateSpec
       Test.DirectiveSpec
       Test.FragmentSpec
-      Test.KitchenSinkSpec
       Test.RootOperationSpec
       Test.StarWars.Data
       Test.StarWars.QuerySpec

package.yaml

@@ -1,5 +1,5 @@
 name:                graphql
-version:             0.8.0.0
+version:             0.10.0.0
 synopsis:            Haskell GraphQL implementation
 description:
   This package provides a rudimentary parser for the
@@ -17,14 +17,11 @@ author:
 
 extra-source-files:
 - CHANGELOG.md
-- README.md
+- CONTRIBUTING.md
 - LICENSE
+- README.md
 - docs/tutorial/tutorial.lhs
 
-data-files:
-- tests/data/*.graphql
-- tests/data/*.min.graphql
-
 dependencies:
 - aeson
 - base >= 4.7 && < 5

src/Language/GraphQL/AST.hs

@@ -1,3 +1,7 @@
+{- This Source Code Form is subject to the terms of the Mozilla Public License,
+   v. 2.0. If a copy of the MPL was not distributed with this file, You can
+   obtain one at https://mozilla.org/MPL/2.0/. -}
+
 -- | Target AST for parser.
 module Language.GraphQL.AST
     ( module Language.GraphQL.AST.Document

src/Language/GraphQL/AST/DirectiveLocation.hs

@@ -1,5 +1,9 @@
+{- This Source Code Form is subject to the terms of the Mozilla Public License,
+   v. 2.0. If a copy of the MPL was not distributed with this file, You can
+   obtain one at https://mozilla.org/MPL/2.0/. -}
+
 -- | Various parts of a GraphQL document can be annotated with directives. 
---   This module describes locations in a document where directives can appear.
+-- This module describes locations in a document where directives can appear.
 module Language.GraphQL.AST.DirectiveLocation
     ( DirectiveLocation(..)
     , ExecutableDirectiveLocation(..)
@@ -7,8 +11,8 @@ module Language.GraphQL.AST.DirectiveLocation
     ) where
 
 -- | All directives can be splitted in two groups: directives used to annotate
---   various parts of executable definitions and the ones used in the schema
---   definition.
+-- various parts of executable definitions and the ones used in the schema
+-- definition.
 data DirectiveLocation
     = ExecutableDirectiveLocation ExecutableDirectiveLocation
     | TypeSystemDirectiveLocation TypeSystemDirectiveLocation

src/Language/GraphQL/AST/Document.hs

@@ -62,6 +62,12 @@ data Location = Location
     , column :: Word
     } deriving (Eq, Show)
 
+instance Ord Location where
+    compare (Location thisLine thisColumn) (Location thatLine thatColumn)
+        | thisLine < thatLine = LT
+        | thisLine > thatLine = GT
+        | otherwise = compare thisColumn thatColumn
+
 -- ** Document
 
 -- | GraphQL document.
@@ -69,7 +75,7 @@ type Document = NonEmpty Definition
 
 -- | All kinds of definitions that can occur in a GraphQL document.
 data Definition
-    = ExecutableDefinition ExecutableDefinition Location
+    = ExecutableDefinition ExecutableDefinition
     | TypeSystemDefinition TypeSystemDefinition Location
     | TypeSystemExtension TypeSystemExtension Location
     deriving (Eq, Show)
@@ -84,13 +90,14 @@ data ExecutableDefinition
 
 -- | Operation definition.
 data OperationDefinition
-    = SelectionSet SelectionSet
+    = SelectionSet SelectionSet Location
     | OperationDefinition
         OperationType
         (Maybe Name)
         [VariableDefinition]
         [Directive]
         SelectionSet
+        Location
     deriving (Eq, Show)
 
 -- | GraphQL has 3 operation types:
@@ -195,7 +202,7 @@ type Alias = Name
 
 -- | Fragment definition.
 data FragmentDefinition
-    = FragmentDefinition Name TypeCondition [Directive] SelectionSet
+    = FragmentDefinition Name TypeCondition [Directive] SelectionSet Location
     deriving (Eq, Show)
 
 -- | Type condition.

src/Language/GraphQL/AST/Encoder.hs

@@ -50,8 +50,8 @@ document formatter defs
     | Minified <-formatter = Lazy.Text.snoc (mconcat encodeDocument) '\n'
   where
     encodeDocument = foldr executableDefinition [] defs
-    executableDefinition (ExecutableDefinition x _) acc =
-        definition formatter x : acc
+    executableDefinition (ExecutableDefinition executableDefinition') acc =
+        definition formatter executableDefinition' : acc
     executableDefinition _ acc = acc
 
 -- | Converts a t'ExecutableDefinition' into a string.
@@ -68,12 +68,12 @@ definition formatter x
 -- | Converts a 'OperationDefinition into a string.
 operationDefinition :: Formatter -> OperationDefinition -> Lazy.Text
 operationDefinition formatter = \case
-    SelectionSet sels -> selectionSet formatter sels
-    OperationDefinition Query name vars dirs sels ->
+    SelectionSet sels _ -> selectionSet formatter sels
+    OperationDefinition Query name vars dirs sels _ ->
         "query " <> node formatter name vars dirs sels
-    OperationDefinition Mutation name vars dirs sels ->
+    OperationDefinition Mutation name vars dirs sels _ ->
         "mutation " <> node formatter name vars dirs sels
-    OperationDefinition Subscription name vars dirs sels ->
+    OperationDefinition Subscription name vars dirs sels _ ->
         "subscription " <> node formatter name vars dirs sels
 
 -- | Converts a Query or Mutation into a string.
@@ -190,7 +190,7 @@ inlineFragment formatter tc dirs sels = "... on "
     <> selectionSet formatter sels
 
 fragmentDefinition :: Formatter -> FragmentDefinition -> Lazy.Text
-fragmentDefinition formatter (FragmentDefinition name tc dirs sels)
+fragmentDefinition formatter (FragmentDefinition name tc dirs sels _)
     = "fragment " <> Lazy.Text.fromStrict name
     <> " on " <> Lazy.Text.fromStrict tc
     <> optempty (directives formatter) dirs

src/Language/GraphQL/AST/Parser.hs

@@ -21,7 +21,8 @@ import Language.GraphQL.AST.DirectiveLocation
 import Language.GraphQL.AST.Document
 import Language.GraphQL.AST.Lexer
 import Text.Megaparsec
-    ( SourcePos(..)
+    ( MonadParsec(..)
+    , SourcePos(..)
     , getSourcePos
     , lookAhead
     , option
@@ -37,15 +38,11 @@ document = unicodeBOM
     *> lexeme (NonEmpty.some definition)
 
 definition :: Parser Definition
-definition = executableDefinition'
+definition = ExecutableDefinition <$> executableDefinition
     <|> typeSystemDefinition'
     <|> typeSystemExtension'
     <?> "Definition"
   where
-    executableDefinition' = do
-        location <- getLocation
-        definition' <- executableDefinition
-        pure $ ExecutableDefinition definition' location
     typeSystemDefinition' = do
         location <- getLocation
         definition' <- typeSystemDefinition
@@ -349,16 +346,22 @@ operationTypeDefinition = OperationTypeDefinition
     <?> "OperationTypeDefinition"
 
 operationDefinition :: Parser OperationDefinition
-operationDefinition = SelectionSet <$> selectionSet
+operationDefinition = shorthand
     <|> operationDefinition'
     <?> "OperationDefinition"
   where
-    operationDefinition'
-        = OperationDefinition <$> operationType
-        <*> optional name
-        <*> variableDefinitions
-        <*> directives
-        <*> selectionSet
+    shorthand = do
+        location <- getLocation
+        selectionSet' <- selectionSet
+        pure $ SelectionSet selectionSet' location
+    operationDefinition' = do
+        location <- getLocation
+        operationType' <- operationType
+        operationName <- optional name
+        variableDefinitions' <- variableDefinitions
+        directives' <- directives
+        selectionSet' <- selectionSet
+        pure $ OperationDefinition operationType' operationName variableDefinitions' directives' selectionSet' location
 
 operationType :: Parser OperationType
 operationType = Query <$ symbol "query"
@@ -412,13 +415,15 @@ inlineFragment = InlineFragment
     <?> "InlineFragment"
 
 fragmentDefinition :: Parser FragmentDefinition
-fragmentDefinition = FragmentDefinition
-    <$  symbol "fragment"
-    <*> name
-    <*> typeCondition
-    <*> directives
-    <*> selectionSet
-    <?> "FragmentDefinition"
+fragmentDefinition =  label "FragmentDefinition" $ do
+    location <- getLocation
+    _ <- symbol "fragment"
+    fragmentName' <- name
+    typeCondition' <- typeCondition
+    directives' <- directives
+    selectionSet' <- selectionSet
+    pure $ FragmentDefinition
+        fragmentName' typeCondition' directives' selectionSet' location
 
 fragmentName :: Parser Name
 fragmentName = but (symbol "on") *> name <?> "FragmentName"

src/Language/GraphQL/Execute/Coerce.hs

@@ -1,3 +1,7 @@
+{- This Source Code Form is subject to the terms of the Mozilla Public License,
+   v. 2.0. If a copy of the MPL was not distributed with this file, You can
+   obtain one at https://mozilla.org/MPL/2.0/. -}
+
 {-# LANGUAGE ExplicitForAll #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ViewPatterns #-}

src/Language/GraphQL/Execute/Execution.hs

@@ -83,30 +83,6 @@ resolveAbstractType abstractType values'
             _ -> 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 :: (MonadCatch m, Serialize a)
     => Out.Resolver m
     -> Type.Value

src/Language/GraphQL/Execute/Transform.hs

@@ -255,18 +255,18 @@ defragment ast =
      in (, fragmentTable) <$> maybe emptyDocument Right nonEmptyOperations
   where
     defragment' definition (operations, fragments')
-        | (Full.ExecutableDefinition executable _) <- definition
+        | (Full.ExecutableDefinition executable) <- definition
         , (Full.DefinitionOperation operation') <- executable =
             (transform operation' : operations, fragments')
-        | (Full.ExecutableDefinition executable _) <- definition
+        | (Full.ExecutableDefinition executable) <- definition
         , (Full.DefinitionFragment fragment) <- executable
-        , (Full.FragmentDefinition name _ _ _) <- fragment =
+        , (Full.FragmentDefinition name _ _ _ _) <- fragment =
             (operations, HashMap.insert name fragment fragments')
     defragment' _ acc = acc
     transform = \case
-        Full.OperationDefinition type' name variables directives' selections ->
+        Full.OperationDefinition type' name variables directives' selections _ ->
             OperationDefinition type' name variables directives' selections
-        Full.SelectionSet selectionSet ->
+        Full.SelectionSet selectionSet _ ->
             OperationDefinition Full.Query Nothing mempty mempty selectionSet
 
 -- * Operation
@@ -324,8 +324,8 @@ selection (Full.InlineFragment type' directives' selections) = do
             case type' of
                 Nothing -> pure $ Left fragmentSelectionSet
                 Just typeName -> do
-                    typeCondition' <- lookupTypeCondition typeName
-                    case typeCondition' of
+                    types' <- gets types
+                    case lookupTypeCondition typeName types' of
                         Just typeCondition -> pure $
                             selectionFragment typeCondition fragmentSelectionSet
                         Nothing -> pure $ Left mempty
@@ -364,29 +364,17 @@ collectFragments = do
         _ <- fragmentDefinition nextValue
         collectFragments
 
-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
+fragmentDefinition (Full.FragmentDefinition name type' _ selections _) = do
     modify deleteFragmentDefinition
     fragmentSelection <- appendSelection selections
-    compositeType <- lookupTypeCondition type'
+    types' <- gets types
 
-    case compositeType of
-        Just compositeType' -> do
-            let newValue = Fragment compositeType' fragmentSelection
+    case lookupTypeCondition type' types' of
+        Just compositeType -> do
+            let newValue = Fragment compositeType fragmentSelection
             modify $ insertFragment newValue
             lift $ pure $ Just newValue
         _ -> lift $ pure Nothing

src/Language/GraphQL/Type/In.hs

@@ -1,3 +1,7 @@
+{- This Source Code Form is subject to the terms of the Mozilla Public License,
+   v. 2.0. If a copy of the MPL was not distributed with this file, You can
+   obtain one at https://mozilla.org/MPL/2.0/. -}
+
 {-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE ViewPatterns #-}
 

src/Language/GraphQL/Type/Internal.hs

@@ -8,6 +8,9 @@ module Language.GraphQL.Type.Internal
     ( AbstractType(..)
     , CompositeType(..)
     , collectReferencedTypes
+    , doesFragmentTypeApply
+    , instanceOf
+    , lookupTypeCondition
     ) where
 
 import Data.HashMap.Strict (HashMap)
@@ -89,3 +92,39 @@ collectReferencedTypes schema =
     polymorphicTraverser interfaces fields
         = flip (foldr visitFields) fields
         . flip (foldr traverseInterfaceType) interfaces
+
+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
+
+lookupTypeCondition :: forall m
+    . Name
+    -> HashMap Name (Type m)
+    -> Maybe (CompositeType m)
+lookupTypeCondition type' types' =
+    case HashMap.lookup type' types' of
+        Just (ObjectType objectType) -> Just $ CompositeObjectType objectType
+        Just (UnionType unionType) -> Just $ CompositeUnionType unionType
+        Just (InterfaceType interfaceType) ->
+            Just $ CompositeInterfaceType interfaceType
+        _ -> Nothing

src/Language/GraphQL/Type/Schema.hs

@@ -1,3 +1,7 @@
+{- This Source Code Form is subject to the terms of the Mozilla Public License,
+   v. 2.0. If a copy of the MPL was not distributed with this file, You can
+   obtain one at https://mozilla.org/MPL/2.0/. -}
+
 -- | This module provides a representation of a @GraphQL@ Schema in addition to
 -- functions for defining and manipulating schemas.
 module Language.GraphQL.Type.Schema

src/Language/GraphQL/Validate.hs

@@ -5,6 +5,7 @@
 {-# LANGUAGE ExplicitForAll #-}
 {-# LANGUAGE LambdaCase #-}
 
+-- | GraphQL validator.
 module Language.GraphQL.Validate
     ( Error(..)
     , Path(..)
@@ -12,66 +13,50 @@ module Language.GraphQL.Validate
     , module Language.GraphQL.Validate.Rules
     ) where
 
-import Control.Monad.Trans.Reader (Reader, asks, runReader)
+import Control.Monad (foldM)
+import Control.Monad.Trans.Reader (Reader, asks, mapReaderT, runReader)
 import Data.Foldable (foldrM)
 import Data.Sequence (Seq(..), (><), (|>))
 import qualified Data.Sequence as Seq
-import Data.Text (Text)
 import Language.GraphQL.AST.Document
-import Language.GraphQL.Type.Schema
+import Language.GraphQL.Type.Internal
+import Language.GraphQL.Type.Schema (Schema(..))
 import Language.GraphQL.Validate.Rules
+import Language.GraphQL.Validate.Validation
 
-data Context m = Context
-    { ast :: Document
-    , schema :: Schema m
-    , rules :: [Rule]
-    }
+type ValidateT m = Reader (Validation m) (Seq Error)
 
-type ValidateT m = Reader (Context m) (Seq Error)
-
-data Path
-    = Segment Text
-    | Index Int
-    deriving (Eq, Show)
-
-data Error = Error
-    { message :: String
-    , locations :: [Location]
-    , path :: [Path]
-    } deriving (Eq, Show)
-
-document :: forall m. Schema m -> [Rule] -> Document -> Seq Error
+-- | Validates a document and returns a list of found errors. If the returned
+-- list is empty, the document is valid.
+document :: forall m. Schema m -> [Rule m] -> Document -> Seq Error
 document schema' rules' document' =
     runReader (foldrM go Seq.empty document') context
   where
-    context = Context
+    context = Validation
         { ast = document'
         , schema = schema'
+        , types = collectReferencedTypes schema'
         , rules = rules'
         }
     go definition' accumulator = (accumulator ><) <$> definition definition'
 
 definition :: forall m. Definition -> ValidateT m
 definition = \case
-    definition'@(ExecutableDefinition executableDefinition' _) -> do
+    definition'@(ExecutableDefinition executableDefinition') -> do
         applied <- applyRules definition'
         children <- executableDefinition executableDefinition'
         pure $ children >< applied
     definition' -> applyRules definition'
   where
-    applyRules definition' = foldr (ruleFilter definition') Seq.empty
-        <$> asks rules
-    ruleFilter definition' (DefinitionRule rule) accumulator
-        | Just message' <- rule definition' =
-            accumulator |> Error
-                { message = message'
-                , locations = [definitionLocation definition']
-                , path = []
-                }
-        | otherwise = accumulator
-    definitionLocation (ExecutableDefinition _ location) = location
-    definitionLocation (TypeSystemDefinition _ location) = location
-    definitionLocation (TypeSystemExtension _ location) = location
+    applyRules definition' =
+        asks rules >>= foldM (ruleFilter definition') Seq.empty
+    ruleFilter definition' accumulator (DefinitionRule rule) =
+        mapReaderT (runRule accumulator) $ rule definition'
+    ruleFilter _ accumulator _ = pure accumulator
+
+runRule :: Applicative f => Seq Error -> Maybe Error -> f (Seq Error)
+runRule accumulator (Just error') = pure $ accumulator |> error'
+runRule accumulator Nothing = pure accumulator
 
 executableDefinition :: forall m. ExecutableDefinition -> ValidateT m
 executableDefinition (DefinitionOperation definition') =
@@ -80,10 +65,17 @@ executableDefinition (DefinitionFragment definition') =
     fragmentDefinition definition'
 
 operationDefinition :: forall m. OperationDefinition -> ValidateT m
-operationDefinition (SelectionSet _operation) =
-    pure Seq.empty
-operationDefinition (OperationDefinition _type _name _variables _directives _selection) =
-    pure Seq.empty
+operationDefinition operation =
+    asks rules >>= foldM ruleFilter Seq.empty
+  where
+    ruleFilter accumulator (OperationDefinitionRule rule) =
+        mapReaderT (runRule accumulator) $ rule operation
+    ruleFilter accumulator _ = pure accumulator
 
 fragmentDefinition :: forall m. FragmentDefinition -> ValidateT m
-fragmentDefinition _fragment = pure Seq.empty
+fragmentDefinition fragment =
+    asks rules >>= foldM ruleFilter Seq.empty
+  where
+    ruleFilter accumulator (FragmentDefinitionRule rule) =
+        mapReaderT (runRule accumulator) $ rule fragment
+    ruleFilter accumulator _ = pure accumulator

src/Language/GraphQL/Validate/Rules.hs

@@ -2,24 +2,214 @@
    v. 2.0. If a copy of the MPL was not distributed with this file, You can
    obtain one at https://mozilla.org/MPL/2.0/. -}
 
+{-# LANGUAGE ExplicitForAll #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ViewPatterns #-}
+
+-- | This module contains default rules defined in the GraphQL specification.
 module Language.GraphQL.Validate.Rules
-    ( Rule(..)
-    , executableDefinitionsRule
+    ( executableDefinitionsRule
+    , loneAnonymousOperationRule
+    , singleFieldSubscriptionsRule
     , specifiedRules
+    , uniqueFragmentNamesRule
+    , uniqueOperationNamesRule
     ) where
 
+import Control.Monad (foldM)
+import Control.Monad.Trans.Class (MonadTrans(..))
+import Control.Monad.Trans.Reader (asks)
+import Control.Monad.Trans.State (evalStateT, gets, modify)
+import qualified Data.HashSet as HashSet
+import qualified Data.Text as Text
 import Language.GraphQL.AST.Document
+import Language.GraphQL.Type.Internal
+import qualified Language.GraphQL.Type.Schema as Schema
+import Language.GraphQL.Validate.Validation
 
-newtype Rule
-    = DefinitionRule (Definition -> Maybe String)
-
-specifiedRules :: [Rule]
+-- | Default rules given in the specification.
+specifiedRules :: forall m. [Rule m]
 specifiedRules =
     [ executableDefinitionsRule
+    , singleFieldSubscriptionsRule
+    , loneAnonymousOperationRule
+    , uniqueOperationNamesRule
+    , uniqueFragmentNamesRule
     ]
 
-executableDefinitionsRule :: Rule
-executableDefinitionsRule = DefinitionRule go
+-- | Definition must be OperationDefinition or FragmentDefinition.
+executableDefinitionsRule :: forall m. Rule m
+executableDefinitionsRule = DefinitionRule $ \case
+    ExecutableDefinition _ -> lift Nothing
+    TypeSystemDefinition _ location -> pure $ error' location
+    TypeSystemExtension _ location -> pure $ error' location
   where
-    go (ExecutableDefinition _definition _) = Nothing
-    go _ = Just "Definition must be OperationDefinition or FragmentDefinition."
+    error' location = Error
+        { message =
+            "Definition must be OperationDefinition or FragmentDefinition."
+        , locations = [location]
+        , path = []
+        }
+
+-- | Subscription operations must have exactly one root field.
+singleFieldSubscriptionsRule :: forall m. Rule m
+singleFieldSubscriptionsRule = OperationDefinitionRule $ \case
+    OperationDefinition Subscription name' _ _ rootFields location -> do
+        groupedFieldSet <- evalStateT (collectFields rootFields) HashSet.empty
+        case HashSet.size groupedFieldSet of
+            1 -> lift Nothing
+            _
+                | Just name <- name' -> pure $ Error
+                    { message = unwords
+                        [ "Subscription"
+                        , Text.unpack name
+                        , "must select only one top level field."
+                        ]
+                    , locations = [location]
+                    , path = []
+                    }
+                | otherwise -> pure $ Error
+                    { message = errorMessage
+                    , locations = [location]
+                    , path = []
+                    }
+    _ -> lift Nothing
+  where
+    errorMessage =
+        "Anonymous Subscription must select only one top level field."
+    collectFields selectionSet = foldM forEach HashSet.empty selectionSet
+    forEach accumulator (Field alias name _ directives _)
+        | any skip directives = pure accumulator
+        | Just aliasedName <- alias = pure
+            $ HashSet.insert aliasedName accumulator
+        | otherwise = pure $ HashSet.insert name accumulator
+    forEach accumulator (FragmentSpread fragmentName directives)
+        | any skip directives = pure accumulator
+        | otherwise = do
+            inVisitetFragments <- gets $ HashSet.member fragmentName
+            if inVisitetFragments
+               then pure accumulator
+               else collectFromSpread fragmentName accumulator
+    forEach accumulator (InlineFragment typeCondition' directives selectionSet)
+        | any skip directives = pure accumulator
+        | Just typeCondition <- typeCondition' =
+            collectFromFragment typeCondition selectionSet accumulator
+        | otherwise = HashSet.union accumulator
+            <$> collectFields selectionSet
+    skip (Directive "skip" [Argument "if" (Boolean True)]) = True
+    skip (Directive "include" [Argument "if" (Boolean False)]) = True
+    skip _ = False
+    findFragmentDefinition (ExecutableDefinition executableDefinition) Nothing
+        | DefinitionFragment fragmentDefinition <- executableDefinition =
+            Just fragmentDefinition
+    findFragmentDefinition _ accumulator = accumulator
+    collectFromFragment typeCondition selectionSet accumulator = do
+        types' <- lift $ asks types
+        schema' <- lift $ asks schema
+        case lookupTypeCondition typeCondition types' of
+            Nothing -> pure accumulator
+            Just compositeType
+                | Just objectType <- Schema.subscription schema'
+                , True <- doesFragmentTypeApply compositeType objectType ->
+                    HashSet.union accumulator<$> collectFields selectionSet
+                | otherwise -> pure accumulator
+    collectFromSpread fragmentName accumulator = do
+        modify $ HashSet.insert fragmentName
+        ast' <- lift $ asks ast
+        case foldr findFragmentDefinition Nothing ast' of
+            Nothing -> pure accumulator
+            Just (FragmentDefinition _ typeCondition _ selectionSet _) ->
+                collectFromFragment typeCondition selectionSet accumulator
+
+-- | GraphQL allows a short‐hand form for defining query operations when only
+-- that one operation exists in the document.
+loneAnonymousOperationRule :: forall m. Rule m
+loneAnonymousOperationRule = OperationDefinitionRule $ \case
+      SelectionSet _ thisLocation -> check thisLocation
+      OperationDefinition _ Nothing _ _ _ thisLocation -> check thisLocation
+      _ -> lift Nothing
+    where
+      check thisLocation = asks ast
+          >>= lift . foldr (filterAnonymousOperations thisLocation) Nothing
+      filterAnonymousOperations thisLocation definition Nothing
+          | (viewOperation -> Just operationDefinition) <- definition =
+              compareAnonymousOperations thisLocation operationDefinition
+      filterAnonymousOperations _ _ accumulator = accumulator
+      compareAnonymousOperations thisLocation = \case
+          OperationDefinition _ _ _ _ _ thatLocation
+              | thisLocation /= thatLocation -> pure $ error' thisLocation
+          SelectionSet _ thatLocation
+              | thisLocation /= thatLocation -> pure $ error' thisLocation
+          _ -> Nothing
+      error' location = Error
+          { message =
+              "This anonymous operation must be the only defined operation."
+          , locations = [location]
+          , path = []
+          }
+
+-- | Each named operation definition must be unique within a document when
+-- referred to by its name.
+uniqueOperationNamesRule :: forall m. Rule m
+uniqueOperationNamesRule = OperationDefinitionRule $ \case
+    OperationDefinition _ (Just thisName) _ _ _ thisLocation ->
+        findDuplicates (filterByName thisName) thisLocation (error' thisName)
+    _ -> lift Nothing
+  where
+    error' operationName = concat
+        [ "There can be only one operation named \""
+        , Text.unpack operationName
+        , "\"."
+        ]
+    filterByName thisName definition' accumulator
+        | (viewOperation -> Just operationDefinition) <- definition'
+        , OperationDefinition _ (Just thatName) _ _ _ thatLocation <- operationDefinition
+        , thisName == thatName = thatLocation : accumulator
+        | otherwise = accumulator
+
+findDuplicates :: (Definition -> [Location] -> [Location])
+    -> Location
+    -> String
+    -> RuleT m
+findDuplicates filterByName thisLocation errorMessage = do
+    ast' <- asks ast
+    let locations' = foldr filterByName [] ast'
+    if length locations' > 1 && head locations' == thisLocation
+        then pure $ error' locations'
+        else lift Nothing
+  where
+    error' locations' = Error 
+        { message = errorMessage
+        , locations = locations'
+        , path = []
+        }
+
+viewOperation :: Definition -> Maybe OperationDefinition
+viewOperation definition
+    | ExecutableDefinition executableDefinition <- definition
+    , DefinitionOperation operationDefinition <- executableDefinition =
+        Just operationDefinition
+viewOperation _ = Nothing
+
+-- | Fragment definitions are referenced in fragment spreads by name. To avoid
+-- ambiguity, each fragment’s name must be unique within a document.
+--
+-- Inline fragments are not considered fragment definitions, and are unaffected
+-- by this validation rule.
+uniqueFragmentNamesRule :: forall m. Rule m
+uniqueFragmentNamesRule = FragmentDefinitionRule $ \case
+    FragmentDefinition thisName _ _ _ thisLocation ->
+        findDuplicates (filterByName thisName) thisLocation (error' thisName)
+  where
+    error' fragmentName = concat
+        [ "There can be only one fragment named \""
+        , Text.unpack fragmentName
+        , "\"."
+        ]
+    filterByName thisName definition accumulator
+        | ExecutableDefinition executableDefinition <- definition
+        , DefinitionFragment fragmentDefinition <- executableDefinition
+        , FragmentDefinition thatName _ _ _ thatLocation <- fragmentDefinition
+        , thisName == thatName = thatLocation : accumulator
+        | otherwise = accumulator

src/Language/GraphQL/Validate/Validation.hs

@@ -0,0 +1,54 @@
+{- This Source Code Form is subject to the terms of the Mozilla Public License,
+   v. 2.0. If a copy of the MPL was not distributed with this file, You can
+   obtain one at https://mozilla.org/MPL/2.0/. -}
+
+-- | Definitions used by the validation rules and the validator itself.
+module Language.GraphQL.Validate.Validation
+    ( Error(..)
+    , Path(..)
+    , Rule(..)
+    , RuleT
+    , Validation(..)
+    ) where
+
+import Control.Monad.Trans.Reader (ReaderT(..))
+import Data.HashMap.Strict (HashMap)
+import Data.Text (Text)
+import Language.GraphQL.AST.Document
+import Language.GraphQL.Type.Schema (Schema)
+import qualified Language.GraphQL.Type.Schema as Schema
+
+-- | If an error can be associated to a particular field in the GraphQL result,
+-- it must contain an entry with the key path that details the path of the
+-- response field which experienced the error. This allows clients to identify
+-- whether a null result is intentional or caused by a runtime error.
+data Path
+    = Segment Text -- ^ Field name.
+    | Index Int -- ^ List index if a field returned a list.
+    deriving (Eq, Show)
+
+-- | Validation error.
+data Error = Error
+    { message :: String
+    , locations :: [Location]
+    , path :: [Path]
+    } deriving (Eq, Show)
+
+-- | Validation rule context.
+data Validation m = Validation
+    { ast :: Document
+    , schema :: Schema m
+    , types :: HashMap Name (Schema.Type m)
+    , rules :: [Rule m]
+    }
+
+-- | 'Rule' assigns a function to each AST node that can be validated. If the
+-- validation fails, the function should return an error message, or 'Nothing'
+-- otherwise.
+data Rule m
+    = DefinitionRule (Definition -> RuleT m)
+    | OperationDefinitionRule (OperationDefinition -> RuleT m)
+    | FragmentDefinitionRule (FragmentDefinition -> RuleT m)
+
+-- | Monad transformer used by the rules.
+type RuleT m = ReaderT (Validation m) Maybe Error

src/Test/Hspec/GraphQL.hs

@@ -11,6 +11,7 @@ module Test.Hspec.GraphQL
     , shouldResolveTo
     ) where
 
+import Control.Monad.Catch (MonadCatch)
 import qualified Data.Aeson as Aeson
 import qualified Data.HashMap.Strict as HashMap
 import Data.Text (Text)
@@ -18,8 +19,8 @@ import Language.GraphQL.Error
 import Test.Hspec.Expectations (Expectation, expectationFailure, shouldBe, shouldNotSatisfy)
 
 -- | Asserts that a query resolves to some value.
-shouldResolveTo
-    :: Either (ResponseEventStream IO Aeson.Value) Aeson.Object
+shouldResolveTo :: MonadCatch m
+    => Either (ResponseEventStream m Aeson.Value) Aeson.Object
     -> Aeson.Object
     -> Expectation
 shouldResolveTo (Right actual) expected = actual `shouldBe` expected
@@ -27,8 +28,8 @@ shouldResolveTo _ _ = expectationFailure
     "the query is expected to resolve to a value, but it resolved to an event stream"
 
 -- | Asserts that the response doesn't contain any errors.
-shouldResolve
-    :: (Text -> IO (Either (ResponseEventStream IO Aeson.Value) Aeson.Object))
+shouldResolve :: MonadCatch m
+    => (Text -> IO (Either (ResponseEventStream m Aeson.Value) Aeson.Object))
     -> Text
     -> Expectation
 shouldResolve executor query = do

stack.yaml

@@ -1,4 +1,4 @@
-resolver: lts-16.5
+resolver: lts-16.11
 
 packages:
 - .

tests/Language/GraphQL/AST/EncoderSpec.hs

@@ -123,7 +123,9 @@ spec = do
         it "indents block strings in arguments" $
             let arguments = [Argument "message" (String "line1\nline2")]
                 field = Field Nothing "field" arguments [] []
-                operation = DefinitionOperation $ SelectionSet $ pure field
+                operation = DefinitionOperation
+                    $ SelectionSet (pure field)
+                    $ Location 0 0
              in definition pretty operation `shouldBe` [r|{
   field(message: """
     line1

tests/Language/GraphQL/ErrorSpec.hs

@@ -1,3 +1,7 @@
+{- This Source Code Form is subject to the terms of the Mozilla Public License,
+   v. 2.0. If a copy of the MPL was not distributed with this file, You can
+   obtain one at https://mozilla.org/MPL/2.0/. -}
+
 {-# LANGUAGE OverloadedStrings #-}
 module Language.GraphQL.ErrorSpec
     ( spec

tests/Language/GraphQL/Execute/CoerceSpec.hs

@@ -1,3 +1,7 @@
+{- This Source Code Form is subject to the terms of the Mozilla Public License,
+   v. 2.0. If a copy of the MPL was not distributed with this file, You can
+   obtain one at https://mozilla.org/MPL/2.0/. -}
+
 {-# LANGUAGE OverloadedStrings #-}
 module Language.GraphQL.Execute.CoerceSpec
     ( spec

tests/Language/GraphQL/Type/OutSpec.hs

@@ -1,3 +1,7 @@
+{- This Source Code Form is subject to the terms of the Mozilla Public License,
+   v. 2.0. If a copy of the MPL was not distributed with this file, You can
+   obtain one at https://mozilla.org/MPL/2.0/. -}
+
 {-# LANGUAGE OverloadedStrings #-}
 module Language.GraphQL.Type.OutSpec
     ( spec

tests/Language/GraphQL/ValidateSpec.hs

@@ -148,7 +148,7 @@ validate queryString =
 
 spec :: Spec
 spec =
-    describe "document" $
+    describe "document" $ do
         it "rejects type definitions" $
             let queryString = [r|
               query getDogName {
@@ -169,3 +169,115 @@ spec =
                     , path = []
                     }
              in validate queryString `shouldBe` Seq.singleton expected
+
+        it "rejects multiple subscription root fields" $
+            let queryString = [r|
+              subscription sub {
+                newMessage {
+                  body
+                  sender
+                }
+                disallowedSecondRootField
+              }
+            |]
+                expected = Error
+                    { message =
+                        "Subscription sub must select only one top level field."
+                    , locations = [AST.Location 2 15]
+                    , path = []
+                    }
+             in validate queryString `shouldBe` Seq.singleton expected
+
+        it "rejects multiple subscription root fields coming from a fragment" $
+            let queryString = [r|
+              subscription sub {
+                ...multipleSubscriptions
+              }
+
+              fragment multipleSubscriptions on Subscription {
+                newMessage {
+                  body
+                  sender
+                }
+                disallowedSecondRootField
+              }
+            |]
+                expected = Error
+                    { message =
+                        "Subscription sub must select only one top level field."
+                    , locations = [AST.Location 2 15]
+                    , path = []
+                    }
+             in validate queryString `shouldBe` Seq.singleton expected
+
+        it "rejects multiple anonymous operations" $
+            let queryString = [r|
+              {
+                dog {
+                  name
+                }
+              }
+
+              query getName {
+                dog {
+                  owner {
+                    name
+                  }
+                }
+              }
+            |]
+                expected = Error
+                    { message =
+                        "This anonymous operation must be the only defined operation."
+                    , locations = [AST.Location 2 15]
+                    , path = []
+                    }
+             in validate queryString `shouldBe` Seq.singleton expected
+
+        it "rejects operations with the same name" $
+            let queryString = [r|
+              query dogOperation {
+                dog {
+                  name
+                }
+              }
+
+              mutation dogOperation {
+                mutateDog {
+                  id
+                }
+            }
+            |]
+                expected = Error
+                    { message =
+                        "There can be only one operation named \"dogOperation\"."
+                    , locations = [AST.Location 2 15, AST.Location 8 15]
+                    , path = []
+                    }
+             in validate queryString `shouldBe` Seq.singleton expected
+
+        it "rejects fragments with the same name" $
+            let queryString = [r|
+              {
+                dog {
+                  ...fragmentOne
+                }
+              }
+
+              fragment fragmentOne on Dog {
+                name
+              }
+
+              fragment fragmentOne on Dog {
+                owner {
+                  name
+                }
+              }
+            |]
+                expected = Error
+                    { message =
+                        "There can be only one fragment named \"fragmentOne\"."
+                    , locations = [AST.Location 8 15, AST.Location 12 15]
+                    , path = []
+                    }
+             in validate queryString `shouldBe` Seq.singleton expected

tests/Test/KitchenSinkSpec.hs

@@ -1,69 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE QuasiQuotes #-}
-module Test.KitchenSinkSpec
-    ( spec
-    ) where
-
-import qualified Data.Text.IO as Text.IO
-import qualified Data.Text.Lazy.IO as Text.Lazy.IO
-import qualified Data.Text.Lazy as Lazy (Text)
-import qualified Language.GraphQL.AST.Encoder as Encoder
-import qualified Language.GraphQL.AST.Parser as Parser
-import Paths_graphql (getDataFileName)
-import Test.Hspec (Spec, describe, it)
-import Test.Hspec.Megaparsec (parseSatisfies)
-import Text.Megaparsec (parse)
-import Text.RawString.QQ (r)
-
-spec :: Spec
-spec = describe "Kitchen Sink" $ do
-    it "minifies the query" $ do
-        dataFileName <- getDataFileName "tests/data/kitchen-sink.graphql"
-        minFileName <- getDataFileName "tests/data/kitchen-sink.min.graphql"
-        expected <- Text.Lazy.IO.readFile minFileName
-
-        shouldNormalize Encoder.minified dataFileName expected
-
-    it "pretty prints the query" $ do
-        dataFileName <- getDataFileName "tests/data/kitchen-sink.graphql"
-        let expected = [r|query queryName($foo: ComplexType, $site: Site = MOBILE) {
-  whoever123is: node(id: [123, 456]) {
-    id
-    ... on User @defer {
-      field2 {
-        id
-        alias: field1(first: 10, after: $foo) @include(if: $foo) {
-          id
-          ...frag
-        }
-      }
-    }
-  }
-}
-
-mutation likeStory {
-  like(story: 123) @defer {
-    story {
-      id
-    }
-  }
-}
-
-fragment frag on Friend {
-  foo(size: $size, bar: $b, obj: {key: "value"})
-}
-
-{
-  unnamed(truthy: true, falsey: false)
-  query
-}
-|]
-
-        shouldNormalize Encoder.pretty dataFileName expected
-
-shouldNormalize :: Encoder.Formatter -> FilePath -> Lazy.Text -> IO ()
-shouldNormalize formatter dataFileName expected = do
-    actual <- Text.IO.readFile dataFileName
-    parse Parser.document dataFileName actual `parseSatisfies` condition
-      where
-        condition = (expected ==) . Encoder.document formatter

tests/data/kitchen-sink.graphql

@@ -1,38 +0,0 @@
-# Copyright (c) 2015, Facebook, Inc.
-# All rights reserved.
-#
-# This source code is licensed under the BSD-style license found in the
-# LICENSE file in the root directory of this source tree. An additional grant
-# of patent rights can be found in the PATENTS file in the same directory.
-
-query queryName($foo: ComplexType, $site: Site = MOBILE) {
-  whoever123is: node(id: [123, 456]) {
-    id, # Inline test comment
-    ... on User @defer {
-      field2 {
-        id,
-        alias: field1(first: 10, after: $foo) @include(if: $foo) {
-          id,
-          ...frag
-        }
-      }
-    }
-  }
-}
-
-mutation likeStory {
-  like(story: 123) @defer {
-    story {
-      id
-    }
-  }
-}
-
-fragment frag on Friend {
-  foo(size: $size, bar: $b, obj: {key: "value"})
-}
-
-{
-  unnamed(truthy: true, falsey: false),
-  query
-}

tests/data/kitchen-sink.min.graphql

@@ -1 +0,0 @@
-query queryName($foo:ComplexType,$site:Site=MOBILE){whoever123is:node(id:[123,456]){id,... on User@defer{field2{id,alias:field1(first:10,after:$foo)@include(if:$foo){id,...frag}}}}}mutation likeStory{like(story:123)@defer{story{id}}}fragment frag on Friend{foo(size:$size,bar:$b,obj:{key:"value"})}{unnamed(truthy:true,falsey:false),query}