Release 1.5.0.0

…not to be an introspection field.

.gitea/deploy.awk

@@ -0,0 +1,3 @@
+END {
+    system("cabal upload --username belka --password "ENVIRON["HACKAGE_PASSWORD"]" "$0)
+}

.gitea/workflows/build.yml

@@ -0,0 +1,33 @@
+name: Build
+
+on:
+  push:
+    branches:
+      - '**'
+  pull_request:
+    branches: [master]
+
+jobs:
+  audit:
+    runs-on: buildenv
+    steps:
+      - uses: actions/checkout@v4
+      - run: hlint -- src tests
+
+  test:
+    runs-on: buildenv
+    steps:
+      - uses: actions/checkout@v4
+      - name: Install dependencies
+        run: cabal update
+      - name: Prepare system
+        run: cabal build graphql-test
+      - run: cabal test --test-show-details=streaming
+
+  doc:
+    runs-on: buildenv
+    steps:
+      - uses: actions/checkout@v4
+      - name: Install dependencies
+        run: cabal update
+      - run: cabal haddock --enable-documentation

.gitea/workflows/release.yml

@@ -0,0 +1,17 @@
+name: Release
+
+on:
+  push:
+    tags:
+      - '**'
+
+jobs:
+  release:
+    runs-on: buildenv
+    steps:
+      - uses: actions/checkout@v4
+      - name: Upload a candidate
+        env:
+          HACKAGE_PASSWORD: ${{ secrets.HACKAGE_PASSWORD }}
+        run: |
+          cabal sdist | awk -f .gitea/deploy.awk

CHANGELOG.md

@@ -6,9 +6,43 @@ The format is based on
 and this project adheres to
 [Haskell Package Versioning Policy](https://pvp.haskell.org/).
 
-## [Unreleased]
+## [1.5.0.0] - 2024-12-03
+### Removed
+- Remove deprecated 'gql' quasi quoter.
+
+### Changed
+- Validate the subscription root not to be an introspection field
+  (`singleFieldSubscriptionsRule`).
+
+## [1.4.0.0] - 2024-10-26
+### Changed
+- `Schema.Directive` is extended to contain a boolean argument, representing
+  repeatable directives. The parser can parse repeatable directive definitions.
+  Validation allows repeatable directives.
+- `AST.Document.Directive` is a record.
+- `gql` quasi quoter is deprecated (moved to graphql-spice package).
+
+### Fixed
+- `gql` quasi quoter recognizeds all GraphQL line endings (CR, LF and CRLF).
+
+### Added
+- @specifiedBy directive.
+
+## [1.3.0.0] - 2024-05-01
+### Changed
+- Remove deprecated `runCollectErrs`, `Resolution`, `CollectErrsT` from the
+  `Error` module.
+
+## [1.2.0.3] - 2024-01-09
+### Fixed
+- Fix corrupted source distribution.
+
+## [1.2.0.2] - 2024-01-09
 ### Fixed
 - `gql` removes not only leading `\n` but also `\r`.
+- Fix non nullable type string representation in executor error messages.
+- Fix input objects not being coerced to lists.
+- Fix used variables are not found in the properties of input objects.
 
 ## [1.2.0.1] - 2023-04-25
 ### Fixed
@@ -512,7 +546,11 @@ and this project adheres to
 ### Added
 - Data types for the GraphQL language.
 
-[Unreleased]: https://git.caraus.tech/OSS/graphql/compare/v1.2.0.1...master
+[1.5.0.0]: https://git.caraus.tech/OSS/graphql/compare/v1.4.0.0...v1.5.0.0
+[1.4.0.0]: https://git.caraus.tech/OSS/graphql/compare/v1.3.0.0...v1.4.0.0
+[1.3.0.0]: https://git.caraus.tech/OSS/graphql/compare/v1.2.0.3...v1.3.0.0
+[1.2.0.3]: https://git.caraus.tech/OSS/graphql/compare/v1.2.0.2...v1.2.0.3
+[1.2.0.2]: https://git.caraus.tech/OSS/graphql/compare/v1.2.0.1...v1.2.0.2
 [1.2.0.1]: https://git.caraus.tech/OSS/graphql/compare/v1.2.0.0...v1.2.0.1
 [1.2.0.0]: https://git.caraus.tech/OSS/graphql/compare/v1.1.0.0...v1.2.0.0
 [1.1.0.0]: https://git.caraus.tech/OSS/graphql/compare/v1.0.3.0...v1.1.0.0

graphql.cabal

@@ -1,7 +1,7 @@
-cabal-version: 2.4
+cabal-version: 3.0
 
 name:           graphql
-version:        1.2.0.1
+version:        1.5.0.0
 synopsis:       Haskell GraphQL implementation
 description:    Haskell <https://spec.graphql.org/June2018/ GraphQL> implementation.
 category:       Language
@@ -11,7 +11,7 @@ author:         Danny Navarro <j@dannynavarro.net>,
                 Matthías Páll Gissurarson <mpg@mpg.is>,
                 Sólrún Halla Einarsdóttir <she@mpg.is>
 maintainer:     belka@caraus.de
-copyright:      (c) 2019-2023 Eugen Wissner,
+copyright:      (c) 2019-2024 Eugen Wissner,
                 (c) 2015-2017 J. Daniel Navarro
 license:        MPL-2.0 AND BSD-3-Clause
 license-files:  LICENSE,
@@ -21,8 +21,7 @@ extra-source-files:
   CHANGELOG.md
   README.md
 tested-with:
-  GHC == 9.2.8,
-  GHC == 9.6.2
+  GHC == 9.8.2
 
 source-repository head
   type: git
@@ -41,7 +40,6 @@ library
     Language.GraphQL.Execute
     Language.GraphQL.Execute.Coerce
     Language.GraphQL.Execute.OrderedMap
-    Language.GraphQL.TH
     Language.GraphQL.Type
     Language.GraphQL.Type.In
     Language.GraphQL.Type.Out
@@ -58,13 +56,12 @@ library
   ghc-options: -Wall
 
   build-depends:
-    base >= 4.7 && < 5,
+    base >= 4.15 && < 5,
     conduit ^>= 1.3.4,
-    containers ^>= 0.6.2,
+    containers >= 0.6 && < 0.8,
     exceptions ^>= 0.10.4,
     megaparsec >= 9.0 && < 10,
     parser-combinators >= 1.3 && < 2,
-    template-haskell >= 2.16 && < 3,
     text >= 1.2 && < 3,
     transformers >= 0.5.6 && < 0.7,
     unordered-containers ^>= 0.2.14,
@@ -85,7 +82,6 @@ test-suite graphql-test
     Language.GraphQL.Execute.CoerceSpec
     Language.GraphQL.Execute.OrderedMapSpec
     Language.GraphQL.ExecuteSpec
-    Language.GraphQL.THSpec
     Language.GraphQL.Type.OutSpec
     Language.GraphQL.Validate.RulesSpec
     Schemas.HeroSchema
@@ -94,7 +90,7 @@ test-suite graphql-test
   ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall
 
   build-depends:
-    QuickCheck ^>= 2.14.1,
+    QuickCheck >= 2.14 && < 2.16,
     base,
     conduit,
     exceptions,
@@ -107,4 +103,6 @@ test-suite graphql-test
     unordered-containers,
     containers,
     vector
+  build-tool-depends:
+    hspec-discover:hspec-discover
   default-language: Haskell2010

src/Language/GraphQL/AST/Document.hs

@@ -371,8 +371,8 @@ data NonNullType
     deriving Eq
 
 instance Show NonNullType where
-    show (NonNullTypeNamed typeName) = '!' : Text.unpack typeName
-    show (NonNullTypeList listType) =  concat ["![", show listType, "]"]
+    show (NonNullTypeNamed typeName) = Text.unpack $ typeName <> "!"
+    show (NonNullTypeList listType) = concat ["[", show listType, "]!"]
 
 -- ** Directives
 
@@ -380,7 +380,11 @@ instance Show NonNullType where
 --
 -- Directives begin with "@", can accept arguments, and can be applied to the
 -- most GraphQL elements, providing additional information.
-data Directive = Directive Name [Argument] Location deriving (Eq, Show)
+data Directive = Directive
+    { name :: Name
+    , arguments :: [Argument]
+    , location :: Location
+    } deriving (Eq, Show)
 
 -- * Type System
 
@@ -405,7 +409,7 @@ data TypeSystemDefinition
     = SchemaDefinition [Directive] (NonEmpty OperationTypeDefinition)
     | TypeDefinition TypeDefinition
     | DirectiveDefinition
-        Description Name ArgumentsDefinition (NonEmpty DirectiveLocation)
+        Description Name ArgumentsDefinition Bool (NonEmpty DirectiveLocation)
     deriving (Eq, Show)
 
 -- ** Type System Extensions
@@ -478,12 +482,9 @@ instance Monoid Description
 data TypeDefinition
     = ScalarTypeDefinition Description Name [Directive]
     | ObjectTypeDefinition
-        Description
-        Name
-        (ImplementsInterfaces [])
-        [Directive]
-        [FieldDefinition]
-    | InterfaceTypeDefinition Description Name [Directive] [FieldDefinition]
+        Description Name (ImplementsInterfaces []) [Directive] [FieldDefinition]
+    | InterfaceTypeDefinition
+        Description Name (ImplementsInterfaces []) [Directive] [FieldDefinition]
     | UnionTypeDefinition Description Name [Directive] (UnionMemberTypes [])
     | EnumTypeDefinition Description Name [Directive] [EnumValueDefinition]
     | InputObjectTypeDefinition

src/Language/GraphQL/AST/Encoder.hs

@@ -159,11 +159,12 @@ typeSystemDefinition formatter = \case
             <> optempty (directives formatter) operationDirectives
             <> bracesList formatter (operationTypeDefinition formatter) (NonEmpty.toList operationTypeDefinitions')
     Full.TypeDefinition typeDefinition' -> typeDefinition formatter typeDefinition'
-    Full.DirectiveDefinition description' name' arguments' locations
+    Full.DirectiveDefinition description' name' arguments' repeatable locations
         -> description formatter description'
         <> "@"
         <> Lazy.Text.fromStrict name'
         <> argumentsDefinition formatter arguments'
+        <> (if repeatable then " repeatable" else mempty)
         <> " on"
         <> pipeList formatter (directiveLocation <$> locations)
 
@@ -225,10 +226,11 @@ typeDefinition formatter = \case
         <> optempty (directives formatter) directives'
         <> eitherFormat formatter " " ""
         <> bracesList formatter (fieldDefinition nextFormatter) fields'
-    Full.InterfaceTypeDefinition description' name' directives' fields'
+    Full.InterfaceTypeDefinition description' name' ifaces' directives' fields'
         -> optempty (description formatter) description'
         <> "interface "
         <> Lazy.Text.fromStrict name'
+        <> optempty (" " <>) (implementsInterfaces ifaces')
         <> optempty (directives formatter) directives'
         <> eitherFormat formatter " " ""
         <> bracesList formatter (fieldDefinition nextFormatter) fields'

src/Language/GraphQL/AST/Lexer.hs

@@ -29,7 +29,8 @@ module Language.GraphQL.AST.Lexer
     , unicodeBOM
     ) where
 
-import Control.Applicative (Alternative(..), liftA2)
+import Control.Applicative (Alternative(..))
+import qualified Control.Applicative.Combinators.NonEmpty as NonEmpty
 import Data.Char (chr, digitToInt, isAsciiLower, isAsciiUpper, ord)
 import Data.Foldable (foldl')
 import Data.List (dropWhileEnd)
@@ -37,7 +38,8 @@ import qualified Data.List.NonEmpty as NonEmpty
 import Data.List.NonEmpty (NonEmpty(..))
 import Data.Proxy (Proxy(..))
 import Data.Void (Void)
-import Text.Megaparsec ( Parsec
+import Text.Megaparsec
+    ( Parsec
     , (<?>)
     , between
     , chunk
@@ -47,7 +49,6 @@ import Text.Megaparsec ( Parsec
     , option
     , optional
     , satisfy
-                       , sepBy
     , skipSome
     , takeP
     , takeWhile1P
@@ -142,12 +143,13 @@ blockString :: Parser T.Text
 blockString = between "\"\"\"" "\"\"\"" stringValue <* spaceConsumer
   where
     stringValue = do
-        byLine <- sepBy (many blockStringCharacter) lineTerminator
-        let indentSize = foldr countIndent 0 $ tail byLine
-            withoutIndent = head byLine : (removeIndent indentSize <$> tail byLine)
+        byLine <- NonEmpty.sepBy1 (many blockStringCharacter) lineTerminator
+        let indentSize = foldr countIndent 0 $ NonEmpty.tail byLine
+            withoutIndent = NonEmpty.head byLine
+                : (removeIndent indentSize <$> NonEmpty.tail byLine)
             withoutEmptyLines = liftA2 (.) dropWhile dropWhileEnd removeEmptyLine withoutIndent
 
-        return $ T.intercalate "\n" $ T.concat <$> withoutEmptyLines
+        pure $ T.intercalate "\n" $ T.concat <$> withoutEmptyLines
     removeEmptyLine [] = True
     removeEmptyLine [x] = T.null x || isWhiteSpace (T.head x)
     removeEmptyLine _ = False
@@ -180,8 +182,8 @@ name :: Parser T.Text
 name = do
     firstLetter <- nameFirstLetter
     rest <- many $ nameFirstLetter <|> digitChar
-    _ <- spaceConsumer
-    return $ TL.toStrict $ TL.cons firstLetter $ TL.pack rest
+    void spaceConsumer
+    pure $ TL.toStrict $ TL.cons firstLetter $ TL.pack rest
   where
     nameFirstLetter = satisfy isAsciiUpper <|> satisfy isAsciiLower <|> char '_'
 
@@ -197,25 +199,25 @@ lineTerminator = chunk "\r\n" <|> chunk "\n" <|> chunk "\r"
 isSourceCharacter :: Char -> Bool
 isSourceCharacter = isSourceCharacter' . ord
   where
-    isSourceCharacter' code = code >= 0x0020
-                           || code == 0x0009
-                           || code == 0x000a
-                           || code == 0x000d
+    isSourceCharacter' code
+        = code >= 0x0020
+        || elem code [0x0009, 0x000a, 0x000d]
 
 escapeSequence :: Parser Char
 escapeSequence = do
-    _ <- char '\\'
+    void $ char '\\'
     escaped <- oneOf ['"', '\\', '/', 'b', 'f', 'n', 'r', 't', 'u']
     case escaped of
-        'b' -> return '\b'
-        'f' -> return '\f'
-        'n' -> return '\n'
-        'r' -> return '\r'
-        't' -> return '\t'
-        'u' -> chr . foldl' step 0
+        'b' -> pure '\b'
+        'f' -> pure '\f'
+        'n' -> pure '\n'
+        'r' -> pure '\r'
+        't' -> pure '\t'
+        'u' -> chr
+            . foldl' step 0
             . chunkToTokens (Proxy :: Proxy T.Text)
             <$> takeP Nothing 4
-        _ -> return escaped
+        _ -> pure escaped
   where
     step accumulator = (accumulator * 16 +) . digitToInt
 

src/Language/GraphQL/AST/Parser.hs

@@ -8,7 +8,7 @@ module Language.GraphQL.AST.Parser
     ( document
     ) where
 
-import Control.Applicative (Alternative(..), liftA2, optional)
+import Control.Applicative (Alternative(..), optional)
 import Control.Applicative.Combinators (sepBy1)
 import qualified Control.Applicative.Combinators.NonEmpty as NonEmpty
 import Data.List.NonEmpty (NonEmpty(..))
@@ -27,6 +27,7 @@ import Text.Megaparsec
     , unPos
     , (<?>)
     )
+import Data.Maybe (isJust)
 
 -- | Parser for the GraphQL documents.
 document :: Parser Full.Document
@@ -82,6 +83,7 @@ directiveDefinition description' = Full.DirectiveDefinition description'
     <* at
     <*> name
     <*> argumentsDefinition
+    <*> (isJust <$> optional (symbol "repeatable"))
     <* symbol "on"
     <*> directiveLocations
     <?> "DirectiveDefinition"
@@ -212,6 +214,7 @@ interfaceTypeDefinition :: Full.Description -> Parser Full.TypeDefinition
 interfaceTypeDefinition description' = Full.InterfaceTypeDefinition description'
     <$ symbol "interface"
     <*> name
+    <*> option (Full.ImplementsInterfaces []) (implementsInterfaces sepBy1)
     <*> directives
     <*> braces (many fieldDefinition)
     <?> "InterfaceTypeDefinition"

src/Language/GraphQL/Error.hs

@@ -8,28 +8,22 @@
 
 -- | Error handling.
 module Language.GraphQL.Error
-    ( CollectErrsT
-    , Error(..)
+    ( Error(..)
     , Path(..)
-    , Resolution(..)
     , ResolverException(..)
     , Response(..)
     , ResponseEventStream
     , parseError
-    , runCollectErrs
     ) where
 
 import Conduit
 import Control.Exception (Exception(..))
-import Control.Monad.Trans.State (StateT, runStateT)
-import Data.HashMap.Strict (HashMap)
 import Data.Sequence (Seq(..), (|>))
 import qualified Data.Sequence as Seq
 import Data.Text (Text)
 import qualified Data.Text as Text
-import Language.GraphQL.AST (Location(..), Name)
+import Language.GraphQL.AST (Location(..))
 import Language.GraphQL.Execute.Coerce
-import qualified Language.GraphQL.Type.Schema as Schema
 import Prelude hiding (null)
 import Text.Megaparsec
     ( ParseErrorBundle(..)
@@ -97,28 +91,3 @@ instance Show ResolverException where
     show (ResolverException e) = show e
 
 instance Exception ResolverException
-
--- * Deprecated
-
-{-# DEPRECATED runCollectErrs "runCollectErrs was part of the old executor and isn't used anymore" #-}
--- | Runs the given query computation, but collects the errors into an error
--- list, which is then sent back with the data.
-runCollectErrs :: (Monad m, Serialize a)
-    => HashMap Name (Schema.Type m)
-    -> CollectErrsT m a
-    -> m (Response a)
-runCollectErrs types' res = do
-    (dat, Resolution{..}) <- runStateT res
-        $ Resolution{ errors = Seq.empty, types = types' }
-    pure $ Response dat errors
-
-{-# DEPRECATED Resolution "Resolution was part of the old executor and isn't used anymore" #-}
--- | Executor context.
-data Resolution m = Resolution
-    { errors :: Seq Error
-    , types :: HashMap Name (Schema.Type m)
-    }
-
-{-# DEPRECATED CollectErrsT "CollectErrsT was part of the old executor and isn't used anymore" #-}
--- | A wrapper to pass error messages around.
-type CollectErrsT m = StateT (Resolution m) m

src/Language/GraphQL/Execute.hs

@@ -556,33 +556,24 @@ coerceArgumentValues argumentDefinitions argumentValues =
                     $ Just inputValue
                 | otherwise -> throwM
                     $ InputCoercionException (Text.unpack argumentName) variableType Nothing
+
     matchFieldValues' = matchFieldValues coerceArgumentValue
         $ Full.node <$> argumentValues
-    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 = coerceArgumentValue 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
+
+    coerceArgumentValue inputType transform =
+      coerceInputLiteral inputType $ extractArgumentValue transform
+
+    extractArgumentValue (Transform.Int integer) = Type.Int integer
+    extractArgumentValue (Transform.Boolean boolean) = Type.Boolean boolean
+    extractArgumentValue (Transform.String string) = Type.String string
+    extractArgumentValue (Transform.Float float) = Type.Float float
+    extractArgumentValue (Transform.Enum enum) = Type.Enum enum
+    extractArgumentValue Transform.Null = Type.Null
+    extractArgumentValue (Transform.List list) =
+      Type.List $ extractArgumentValue <$> list
+    extractArgumentValue (Transform.Object object) =
+      Type.Object $ extractArgumentValue <$> object
+    extractArgumentValue (Transform.Variable variable) = variable
 
 collectFields :: Monad m
     => Out.ObjectType m

src/Language/GraphQL/TH.hs

@@ -1,47 +0,0 @@
-{- 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/. -}
-
--- | Template Haskell helpers.
-module Language.GraphQL.TH
-    ( gql
-    ) where
-
-import Language.Haskell.TH.Quote (QuasiQuoter(..))
-import Language.Haskell.TH (Exp(..), Lit(..))
-
-stripIndentation :: String -> String
-stripIndentation code = reverse
-    $ dropWhile isLineBreak
-    $ reverse
-    $ unlines
-    $ indent spaces <$> lines' withoutLeadingNewlines
-  where
-    indent 0 xs = xs
-    indent count (' ' : xs) = indent (count - 1) xs
-    indent _ xs = xs
-    withoutLeadingNewlines = dropWhile isLineBreak code
-    spaces = length $ takeWhile (== ' ') withoutLeadingNewlines
-    lines' "" = []
-    lines' string =
-        let (line, rest) = break isLineBreak string
-            reminder =
-                case rest of
-                    [] -> []
-                    '\r' : '\n' : strippedString -> lines strippedString
-                    _ : strippedString -> lines strippedString
-         in line : reminder
-    isLineBreak = flip any ['\n', '\r'] . (==)
-
--- | Removes leading and trailing newlines. Indentation of the first line is
--- removed from each line of the string.
-gql :: QuasiQuoter
-gql = QuasiQuoter
-    { quoteExp = pure . LitE . StringL . stripIndentation
-    , quotePat = const
-        $ fail "Illegal gql QuasiQuote (allowed as expression only, used as a pattern)"
-    , quoteType = const
-        $ fail "Illegal gql QuasiQuote (allowed as expression only, used as a type)"
-    , quoteDec = const
-        $ fail "Illegal gql QuasiQuote (allowed as expression only, used as a declaration)"
-    }

src/Language/GraphQL/Type/Definition.hs

@@ -18,6 +18,8 @@ module Language.GraphQL.Type.Definition
     , float
     , id
     , int
+    , showNonNullType
+    , showNonNullListType
     , selection
     , string
     ) where
@@ -207,3 +209,11 @@ include = handle include'
             (Just (Boolean True)) -> Include directive'
             _ -> Skip
     include' directive' = Continue directive'
+
+showNonNullType :: Show a => a -> String
+showNonNullType = (++ "!") . show
+
+showNonNullListType :: Show a => a -> String
+showNonNullListType listType =
+    let representation = show listType
+     in concat ["[", representation, "]!"]

src/Language/GraphQL/Type/In.hs

@@ -66,13 +66,15 @@ instance Show Type where
     show (NamedEnumType enumType) = show enumType
     show (NamedInputObjectType inputObjectType) = show inputObjectType
     show (ListType baseType) = concat ["[", show baseType, "]"]
-    show (NonNullScalarType scalarType) = '!' : show scalarType
-    show (NonNullEnumType enumType) = '!' : show enumType
-    show (NonNullInputObjectType inputObjectType) = '!' : show inputObjectType
-    show (NonNullListType baseType) = concat ["![", show baseType, "]"]
+    show (NonNullScalarType scalarType) = Definition.showNonNullType scalarType
+    show (NonNullEnumType enumType) = Definition.showNonNullType enumType
+    show (NonNullInputObjectType inputObjectType) =
+        Definition.showNonNullType inputObjectType
+    show (NonNullListType baseType) = Definition.showNonNullListType baseType
 
 -- | Field argument definition.
 data Argument = Argument (Maybe Text) Type (Maybe Definition.Value)
+    deriving Eq
 
 -- | Field argument definitions.
 type Arguments = HashMap Name Argument

src/Language/GraphQL/Type/Internal.hs

@@ -48,7 +48,11 @@ data Type m
     deriving Eq
 
 -- | Directive definition.
-data Directive = Directive (Maybe Text) [DirectiveLocation] In.Arguments
+--
+-- A definition consists of an optional description, arguments, whether the
+-- directive is repeatable, and the allowed directive locations.
+data Directive = Directive (Maybe Text) In.Arguments Bool [DirectiveLocation]
+    deriving Eq
 
 -- | Directive definitions.
 type Directives = HashMap Full.Name Directive

src/Language/GraphQL/Type/Out.hs

@@ -115,12 +115,12 @@ instance forall a. Show (Type a) where
     show (NamedInterfaceType interfaceType) = show interfaceType
     show (NamedUnionType unionType) = show unionType
     show (ListType baseType) = concat ["[", show baseType, "]"]
-    show (NonNullScalarType scalarType) = '!' : show scalarType
-    show (NonNullEnumType enumType) = '!' : show enumType
-    show (NonNullObjectType inputObjectType) = '!' : show inputObjectType
-    show (NonNullInterfaceType interfaceType) = '!' : show interfaceType
-    show (NonNullUnionType unionType) = '!' : show unionType
-    show (NonNullListType baseType) = concat ["![", show baseType, "]"]
+    show (NonNullScalarType scalarType) = showNonNullType scalarType
+    show (NonNullEnumType enumType) = showNonNullType enumType
+    show (NonNullObjectType inputObjectType) = showNonNullType inputObjectType
+    show (NonNullInterfaceType interfaceType) = showNonNullType interfaceType
+    show (NonNullUnionType unionType) = showNonNullType unionType
+    show (NonNullListType baseType) = showNonNullListType baseType
 
 -- | Matches either 'NamedScalarType' or 'NonNullScalarType'.
 pattern ScalarBaseType :: forall m. ScalarType -> Type m

src/Language/GraphQL/Type/Schema.hs

@@ -85,15 +85,16 @@ schemaWithTypes description' queryRoot mutationRoot subscriptionRoot types' dire
         [ ("skip", skipDirective)
         , ("include", includeDirective)
         , ("deprecated", deprecatedDirective)
+        , ("specifiedBy", specifiedByDirective)
         ]
     includeDirective =
-        Directive includeDescription skipIncludeLocations includeArguments
+        Directive includeDescription includeArguments False skipIncludeLocations
     includeArguments = HashMap.singleton "if"
         $ In.Argument (Just "Included when true.") ifType Nothing
     includeDescription = Just
         "Directs the executor to include this field or fragment only when the \
         \`if` argument is true."
-    skipDirective = Directive skipDescription skipIncludeLocations skipArguments
+    skipDirective = Directive skipDescription skipArguments False skipIncludeLocations
     skipArguments = HashMap.singleton "if"
         $ In.Argument (Just "skipped when true.") ifType Nothing
     ifType = In.NonNullScalarType Definition.boolean
@@ -106,16 +107,15 @@ schemaWithTypes description' queryRoot mutationRoot subscriptionRoot types' dire
         , ExecutableDirectiveLocation DirectiveLocation.InlineFragment
         ]
     deprecatedDirective =
-        Directive deprecatedDescription deprecatedLocations deprecatedArguments
+        Directive deprecatedDescription deprecatedArguments False deprecatedLocations
     reasonDescription = Just
         "Explains why this element was deprecated, usually also including a \
         \suggestion for how to access supported similar data. Formatted using \
         \the Markdown syntax, as specified by \
         \[CommonMark](https://commonmark.org/).'"
     deprecatedArguments = HashMap.singleton "reason"
-        $ In.Argument reasonDescription reasonType
+        $ In.Argument reasonDescription (In.NamedScalarType Definition.string)
         $ Just "No longer supported"
-    reasonType = In.NamedScalarType Definition.string
     deprecatedDescription = Just
         "Marks an element of a GraphQL schema as no longer supported."
     deprecatedLocations =
@@ -124,6 +124,16 @@ schemaWithTypes description' queryRoot mutationRoot subscriptionRoot types' dire
         , TypeSystemDirectiveLocation DirectiveLocation.InputFieldDefinition
         , TypeSystemDirectiveLocation DirectiveLocation.EnumValue
         ]
+    specifiedByDirective =
+        Directive specifiedByDescription specifiedByArguments False specifiedByLocations
+    urlDescription = Just
+        "The URL that specifies the behavior of this scalar."
+    specifiedByArguments = HashMap.singleton "url"
+        $ In.Argument urlDescription (In.NonNullScalarType Definition.string) Nothing
+    specifiedByDescription = Just
+        "Exposes a URL that specifies the behavior of this scalar."
+    specifiedByLocations =
+        [TypeSystemDirectiveLocation DirectiveLocation.Scalar]
 
 -- | Traverses the schema and finds all referenced types.
 collectReferencedTypes :: forall m

src/Language/GraphQL/Validate.hs

@@ -200,7 +200,7 @@ typeSystemDefinition context rule = \case
         directives context rule schemaLocation directives'
     Full.TypeDefinition typeDefinition' ->
         typeDefinition context rule typeDefinition'
-    Full.DirectiveDefinition _ _ arguments' _ ->
+    Full.DirectiveDefinition _ _ arguments' _ _ ->
         argumentsDefinition context rule arguments'
 
 typeDefinition :: forall m. Validation m -> ApplyRule m Full.TypeDefinition
@@ -210,7 +210,7 @@ typeDefinition context rule = \case
     Full.ObjectTypeDefinition _ _ _ directives' fields
         -> directives context rule objectLocation directives'
         >< foldMap (fieldDefinition context rule) fields
-    Full.InterfaceTypeDefinition _ _ directives' fields
+    Full.InterfaceTypeDefinition _ _ _ directives' fields
         -> directives context rule interfaceLocation directives'
         >< foldMap (fieldDefinition context rule) fields
     Full.UnionTypeDefinition _ _ directives' _ ->
@@ -482,4 +482,4 @@ directive context rule (Full.Directive directiveName arguments' _) =
             $ Validation.schema context
      in arguments rule argumentTypes arguments'
   where
-    directiveArguments (Schema.Directive _ _ argumentTypes) = argumentTypes
+    directiveArguments (Schema.Directive _ argumentTypes _ _) = argumentTypes

src/Language/GraphQL/Validate/Rules.hs

@@ -2,11 +2,13 @@
    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 DataKinds #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE ViewPatterns #-}
 
 -- | This module contains default rules defined in the GraphQL specification.
@@ -48,19 +50,21 @@ import Control.Monad.Trans.Class (MonadTrans(..))
 import Control.Monad.Trans.Reader (ReaderT(..), ask, asks, mapReaderT)
 import Control.Monad.Trans.State (StateT, evalStateT, gets, modify)
 import Data.Bifunctor (first)
-import Data.Foldable (find, fold, foldl', toList)
+import Data.Foldable (Foldable(..), find)
 import qualified Data.HashMap.Strict as HashMap
 import Data.HashMap.Strict (HashMap)
 import Data.HashSet (HashSet)
 import qualified Data.HashSet as HashSet
-import Data.List (groupBy, sortBy, sortOn)
+import Data.List (sortBy)
 import Data.Maybe (fromMaybe, isJust, isNothing, mapMaybe)
 import Data.List.NonEmpty (NonEmpty(..))
+import qualified Data.List.NonEmpty as NonEmpty
 import Data.Ord (comparing)
 import Data.Sequence (Seq(..), (|>))
 import qualified Data.Sequence as Seq
 import Data.Text (Text)
 import qualified Data.Text as Text
+import GHC.Records (HasField(..))
 import qualified Language.GraphQL.AST.Document as Full
 import qualified Language.GraphQL.Type.Definition as Definition
 import qualified Language.GraphQL.Type.Internal as Type
@@ -133,25 +137,28 @@ singleFieldSubscriptionsRule :: forall m. Rule m
 singleFieldSubscriptionsRule = OperationDefinitionRule $ \case
     Full.OperationDefinition Full.Subscription name' _ _ rootFields location' -> do
         groupedFieldSet <- evalStateT (collectFields rootFields) HashSet.empty
-        case HashSet.size groupedFieldSet of
-            1 -> lift mempty
-            _
-                | Just name <- name' -> pure $ Error
+        case HashSet.toList groupedFieldSet of
+            [rootName]
+                | Text.isPrefixOf "__" rootName -> makeError location' name'
+                    "exactly one top level field, which must not be an introspection field."
+                | otherwise -> lift mempty
+            [] -> makeError location' name' "exactly one top level field."
+            _ -> makeError location' name' "only one top level field."
+    _ -> lift mempty
+  where
+    makeError location' (Just operationName) errorLine = pure $ Error
         { message = concat
             [ "Subscription \""
-                        , Text.unpack name
-                        , "\" must select only one top level field."
+            , Text.unpack operationName
+            , "\" must select "
+            , errorLine
             ]
         , locations = [location']
         }
-                | otherwise -> pure $ Error
-                    { message = errorMessage
+    makeError location' Nothing errorLine = pure $ Error
+        { message = "Anonymous Subscription must select " <> errorLine
         , locations = [location']
         }
-    _ -> lift mempty
-  where
-    errorMessage =
-        "Anonymous Subscription must select only one top level field."
     collectFields = foldM forEach HashSet.empty
     forEach accumulator = \case
         Full.FieldSelection fieldSelection -> forField accumulator fieldSelection
@@ -250,14 +257,16 @@ findDuplicates :: (Full.Definition -> [Full.Location] -> [Full.Location])
     -> Full.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 mempty
+findDuplicates filterByName thisLocation errorMessage =
+    asks ast >>= go . foldr filterByName []
   where
-    error' locations' = Error 
+    go locations' =
+        case locations' of
+            headLocation : otherLocations -- length locations' > 1
+                | not $ null otherLocations
+                , headLocation == thisLocation -> pure $ makeError locations'
+            _ -> lift mempty
+    makeError locations' = Error
         { message = errorMessage
         , locations = locations'
         }
@@ -527,16 +536,20 @@ uniqueArgumentNamesRule = ArgumentsRule fieldRule directiveRule
 -- used, the expected metadata or behavior becomes ambiguous, therefore only one
 -- of each directive is allowed per location.
 uniqueDirectiveNamesRule :: forall m. Rule m
-uniqueDirectiveNamesRule = DirectivesRule
-    $ const $ lift . filterDuplicates extract "directive"
+uniqueDirectiveNamesRule = DirectivesRule $ const $ \directives' -> do
+    definitions' <- asks $ Schema.directives . schema
+    let filterNonRepeatable = flip HashSet.member nonRepeatableSet
+            . getField @"name"
+        nonRepeatableSet =
+            HashMap.foldlWithKey foldNonRepeatable HashSet.empty definitions'
+    lift $ filterDuplicates extract "directive"
+        $ filter filterNonRepeatable directives'
   where
-    extract (Full.Directive directiveName _ location') =
-        (directiveName, location')
-
-groupSorted :: forall a. (a -> Text) -> [a] -> [[a]]
-groupSorted getName = groupBy equalByName . sortOn getName
-  where
-    equalByName lhs rhs = getName lhs == getName rhs
+    foldNonRepeatable  hashSet directiveName' (Schema.Directive _ _ False _) =
+        HashSet.insert directiveName' hashSet
+    foldNonRepeatable hashSet _ _ = hashSet
+    extract (Full.Directive directiveName' _ location') =
+        (directiveName', location')
 
 filterDuplicates :: forall a
     . (a -> (Text, Full.Location))
@@ -546,12 +559,12 @@ filterDuplicates :: forall a
 filterDuplicates extract nodeType = Seq.fromList
     . fmap makeError
     . filter ((> 1) . length)
-    . groupSorted getName
+    . NonEmpty.groupAllWith getName
   where
     getName = fst . extract
     makeError directives' = Error
-        { message = makeMessage $ head directives'
-        , locations = snd . extract <$> directives'
+        { message = makeMessage $ NonEmpty.head directives'
+        , locations = snd . extract <$> toList directives'
         }
     makeMessage directive = concat
         [ "There can be only one "
@@ -618,6 +631,10 @@ noUndefinedVariablesRule =
         , "\"."
         ]
 
+-- Used to find the difference between defined and used variables. The first
+-- argument are variables defined in the operation, the second argument are
+-- variables used in the query. It should return the difference between these
+-- 2 sets.
 type UsageDifference
     = HashMap Full.Name [Full.Location]
     -> HashMap Full.Name [Full.Location]
@@ -664,11 +681,17 @@ variableUsageDifference difference errorMessage = OperationDefinitionRule $ \cas
         = filterSelections' selections
         >>= lift . mapReaderT (<> mapDirectives directives') . pure
     findDirectiveVariables (Full.Directive _ arguments _) = mapArguments arguments
-    mapArguments = Seq.fromList . mapMaybe findArgumentVariables
+    mapArguments = Seq.fromList . (>>= findArgumentVariables)
     mapDirectives = foldMap findDirectiveVariables
-    findArgumentVariables (Full.Argument _ Full.Node{ node = Full.Variable value', ..} _) =
-        Just (value', [location])
-    findArgumentVariables _ = Nothing
+
+    findArgumentVariables (Full.Argument _ value _) = findNodeVariables value
+    findNodeVariables Full.Node{ node = value, ..} = findValueVariables location value
+
+    findValueVariables location (Full.Variable value') = [(value', [location])]
+    findValueVariables _ (Full.List values) = values >>= findNodeVariables
+    findValueVariables _ (Full.Object fields) = fields
+        >>= findNodeVariables . getField @"value"
+    findValueVariables _ _ = []
     makeError operationName (variableName, locations') = Error
         { message = errorMessage operationName variableName
         , locations = locations'
@@ -820,7 +843,7 @@ knownArgumentNamesRule = ArgumentsRule fieldRule directiveRule
             . Schema.directives . schema
         Full.Argument argumentName _ location' <- lift $ Seq.fromList arguments
         case available of
-            Just (Schema.Directive _ _ definitions)
+            Just (Schema.Directive _ definitions _ _)
                 | not $ HashMap.member argumentName definitions ->
                     pure $ makeError argumentName directiveName location'
             _ -> lift mempty
@@ -836,23 +859,23 @@ knownArgumentNamesRule = ArgumentsRule fieldRule directiveRule
         , "\"."
         ]
 
--- | GraphQL servers define what directives they support. For each usage of a
--- directive, the directive must be available on that server.
+-- | GraphQL services define what directives they support. For each usage of a
+-- directive, the directive must be available on that service.
 knownDirectiveNamesRule :: Rule m
 knownDirectiveNamesRule = DirectivesRule $ const $ \directives' -> do
     definitions' <- asks $ Schema.directives . schema
-    let directiveSet = HashSet.fromList $ fmap directiveName directives'
-    let definitionSet = HashSet.fromList $ HashMap.keys definitions'
-    let difference = HashSet.difference directiveSet definitionSet
-    let undefined' = filter (definitionFilter difference) directives'
+    let directiveSet = HashSet.fromList $ fmap (getField @"name") directives'
+        definitionSet = HashSet.fromList $ HashMap.keys definitions'
+        difference = HashSet.difference directiveSet definitionSet
+        undefined' = filter (definitionFilter difference) directives'
     lift $ Seq.fromList $ makeError <$> undefined'
   where
+    definitionFilter :: HashSet Full.Name -> Full.Directive -> Bool
     definitionFilter difference = flip HashSet.member difference
-        . directiveName
-    directiveName (Full.Directive directiveName' _ _) = directiveName'
-    makeError (Full.Directive directiveName' _ location') = Error
-        { message = errorMessage directiveName'
-        , locations = [location']
+        . getField @"name"
+    makeError Full.Directive{..} = Error
+        { message = errorMessage name
+        , locations = [location]
         }
     errorMessage directiveName' = concat
         [ "Unknown directive \"@"
@@ -889,9 +912,9 @@ knownInputFieldNamesRule = ValueRule go constGo
         , "\"."
         ]
 
--- | GraphQL servers define what directives they support and where they support
+-- | GraphQL services define what directives they support and where they support
 -- them. For each usage of a directive, the directive must be used in a location
--- that the server has declared support for.
+-- that the service has declared support for.
 directivesInValidLocationsRule :: Rule m
 directivesInValidLocationsRule = DirectivesRule directivesRule
   where
@@ -900,7 +923,7 @@ directivesInValidLocationsRule = DirectivesRule directivesRule
         maybeDefinition <- asks
             $ HashMap.lookup directiveName . Schema.directives . schema
         case maybeDefinition of
-            Just (Schema.Directive _ allowedLocations _)
+            Just (Schema.Directive _ _ _ allowedLocations)
                 | directiveLocation `notElem` allowedLocations -> pure $ Error
                     { message = errorMessage directiveName directiveLocation
                     , locations = [location]
@@ -930,7 +953,7 @@ providedRequiredArgumentsRule = ArgumentsRule fieldRule directiveRule
         available <- asks
             $ HashMap.lookup directiveName . Schema.directives . schema
         case available of
-            Just (Schema.Directive _ _ definitions) ->
+            Just (Schema.Directive _ definitions _ _) ->
                 let forEach = go (directiveMessage directiveName) arguments location'
                  in lift $ HashMap.foldrWithKey forEach Seq.empty definitions
             _ -> lift mempty
@@ -1398,7 +1421,7 @@ variablesInAllowedPositionRule = OperationDefinitionRule $ \case
         let Full.Directive directiveName arguments _ = directive
         directiveDefinitions <- lift $ asks $ Schema.directives . schema
         case HashMap.lookup directiveName directiveDefinitions of
-            Just (Schema.Directive _ _ directiveArguments) ->
+            Just (Schema.Directive _ directiveArguments _ _) ->
                 mapArguments variables directiveArguments arguments
             Nothing -> pure mempty
     mapArguments variables argumentTypes = fmap fold

tests/Language/GraphQL/AST/Arbitrary.hs

@@ -1,14 +1,26 @@
 {-# LANGUAGE OverloadedStrings #-}
 
-module Language.GraphQL.AST.Arbitrary where
+module Language.GraphQL.AST.Arbitrary
+    ( AnyArgument(..)
+    , AnyLocation(..)
+    , AnyName(..)
+    , AnyNode(..)
+    , AnyObjectField(..)
+    , AnyValue(..)
+    , printArgument
+    ) where
 
 import qualified Language.GraphQL.AST.Document as Doc
 import Test.QuickCheck.Arbitrary (Arbitrary (arbitrary))
 import Test.QuickCheck (oneof, elements, listOf, resize, NonEmptyList (..))
 import Test.QuickCheck.Gen (Gen (..))
-import Data.Text (Text, pack)
+import Data.Text (Text)
+import qualified Data.Text as Text
+import Data.Functor ((<&>))
 
-newtype AnyPrintableChar = AnyPrintableChar { getAnyPrintableChar :: Char } deriving (Eq, Show)
+newtype AnyPrintableChar = AnyPrintableChar
+    { getAnyPrintableChar :: Char
+    } deriving (Eq, Show)
 
 alpha :: String
 alpha = ['a'..'z'] <> ['A'..'Z']
@@ -21,28 +33,40 @@ instance Arbitrary AnyPrintableChar where
         where
            chars = alpha <> num <> ['_']
 
-newtype AnyPrintableText = AnyPrintableText { getAnyPrintableText :: Text } deriving (Eq, Show)
+newtype AnyPrintableText = AnyPrintableText
+    { getAnyPrintableText :: Text
+    } deriving (Eq, Show)
 
 instance Arbitrary AnyPrintableText where
     arbitrary = do
         nonEmptyStr <- getNonEmpty <$> (arbitrary :: Gen (NonEmptyList AnyPrintableChar))
-        pure $ AnyPrintableText (pack $ map getAnyPrintableChar nonEmptyStr)
+        pure $ AnyPrintableText
+            $ Text.pack
+            $ map getAnyPrintableChar nonEmptyStr
 
 -- https://spec.graphql.org/June2018/#Name
-newtype AnyName = AnyName { getAnyName :: Text } deriving (Eq, Show)
+newtype AnyName = AnyName
+    { getAnyName :: Text
+    } deriving (Eq, Show)
 
 instance Arbitrary AnyName where
     arbitrary = do
         firstChar <- elements $ alpha <> ['_']
         rest <- (arbitrary :: Gen [AnyPrintableChar])
-        pure $ AnyName (pack $ firstChar : map getAnyPrintableChar rest)
+        pure $ AnyName
+            $ Text.pack
+            $ firstChar : map getAnyPrintableChar rest
 
-newtype AnyLocation = AnyLocation { getAnyLocation :: Doc.Location } deriving (Eq, Show)
+newtype AnyLocation = AnyLocation
+    { getAnyLocation :: Doc.Location
+    } deriving (Eq, Show)
 
 instance Arbitrary AnyLocation where
     arbitrary = AnyLocation <$> (Doc.Location <$> arbitrary <*> arbitrary)
 
-newtype AnyNode a = AnyNode { getAnyNode :: Doc.Node a } deriving (Eq, Show)
+newtype AnyNode a = AnyNode
+    { getAnyNode :: Doc.Node a
+    } deriving (Eq, Show)
 
 instance Arbitrary a => Arbitrary (AnyNode a) where
     arbitrary = do
@@ -50,7 +74,9 @@ instance Arbitrary a => Arbitrary (AnyNode a) where
         node' <- flip Doc.Node location' <$> arbitrary
         pure $ AnyNode node'
 
-newtype AnyObjectField a = AnyObjectField { getAnyObjectField :: Doc.ObjectField a } deriving (Eq, Show)
+newtype AnyObjectField a = AnyObjectField
+    { getAnyObjectField :: Doc.ObjectField a
+    } deriving (Eq, Show)
 
 instance Arbitrary a => Arbitrary (AnyObjectField a) where
     arbitrary = do
@@ -59,34 +85,38 @@ instance Arbitrary a => Arbitrary (AnyObjectField a) where
         location' <- getAnyLocation <$> arbitrary
         pure $ AnyObjectField $ Doc.ObjectField name' value' location'
 
-newtype AnyValue = AnyValue { getAnyValue :: Doc.Value } deriving (Eq, Show)
+newtype AnyValue = AnyValue
+    { getAnyValue :: Doc.Value
+    } deriving (Eq, Show)
 
-instance Arbitrary AnyValue where
-    arbitrary = AnyValue <$> oneof
+instance Arbitrary AnyValue
+  where
+    arbitrary =
+        let variableGen :: Gen Doc.Value
+            variableGen = Doc.Variable . getAnyName <$> arbitrary
+            listGen :: Gen [Doc.Node Doc.Value]
+            listGen = (resize 5 . listOf) nodeGen
+            nodeGen :: Gen (Doc.Node Doc.Value)
+            nodeGen = fmap getAnyNode arbitrary <&> fmap getAnyValue
+            objectGen :: Gen [Doc.ObjectField Doc.Value]
+            objectGen = resize 1
+                $ fmap getNonEmpty arbitrary
+                <&> map (fmap getAnyValue . getAnyObjectField)
+         in AnyValue <$> oneof
             [ variableGen
             , Doc.Int <$> arbitrary
             , Doc.Float <$> arbitrary
-        , Doc.String <$> (getAnyPrintableText <$> arbitrary)
+            , Doc.String . getAnyPrintableText <$> arbitrary
             , Doc.Boolean <$> arbitrary
             , MkGen $ \_ _ -> Doc.Null
-        , Doc.Enum <$> (getAnyName <$> arbitrary)
+            , Doc.Enum . getAnyName <$> arbitrary
             , Doc.List <$> listGen
             , Doc.Object <$> objectGen
             ]
-            where
-                variableGen :: Gen Doc.Value
-                variableGen = Doc.Variable <$> (getAnyName <$> arbitrary)
-                listGen :: Gen [Doc.Node Doc.Value]
-                listGen = (resize 5 . listOf) nodeGen
-                nodeGen = do
-                    node' <- getAnyNode <$> (arbitrary :: Gen (AnyNode AnyValue))
-                    pure (getAnyValue <$> node')
-                objectGen :: Gen [Doc.ObjectField Doc.Value]
-                objectGen = resize 1 $ do
-                    list <- getNonEmpty <$> (arbitrary :: Gen (NonEmptyList (AnyObjectField AnyValue)))
-                    pure $ map (fmap getAnyValue . getAnyObjectField) list
 
-newtype AnyArgument a = AnyArgument { getAnyArgument :: Doc.Argument } deriving (Eq, Show)
+newtype AnyArgument a = AnyArgument
+    { getAnyArgument :: Doc.Argument
+    } deriving (Eq, Show)
 
 instance Arbitrary a => Arbitrary (AnyArgument a) where
     arbitrary = do
@@ -96,4 +126,5 @@ instance Arbitrary a => Arbitrary (AnyArgument a) where
         pure $ AnyArgument $ Doc.Argument name' (Doc.Node value' location') location'
 
 printArgument :: AnyArgument AnyValue -> Text
-printArgument (AnyArgument (Doc.Argument name' (Doc.Node value' _) _)) = name' <> ": " <> (pack . show) value'
+printArgument (AnyArgument (Doc.Argument name' (Doc.Node value' _) _)) =
+    name' <> ": " <> (Text.pack . show) value'

tests/Language/GraphQL/AST/EncoderSpec.hs

@@ -1,5 +1,4 @@
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE QuasiQuotes #-}
 module Language.GraphQL.AST.EncoderSpec
     ( spec
     ) where
@@ -7,20 +6,17 @@ module Language.GraphQL.AST.EncoderSpec
 import Data.List.NonEmpty (NonEmpty(..))
 import qualified Language.GraphQL.AST.Document as Full
 import Language.GraphQL.AST.Encoder
-import Language.GraphQL.TH
 import Test.Hspec (Spec, context, describe, it, shouldBe, shouldStartWith, shouldEndWith, shouldNotContain)
 import Test.QuickCheck (choose, oneof, forAll)
 import qualified Data.Text.Lazy as Text.Lazy
+import qualified Language.GraphQL.AST.DirectiveLocation as DirectiveLocation
 
 spec :: Spec
 spec = do
     describe "value" $ do
-        context "null value" $ do
-            let testNull formatter = value formatter Full.Null `shouldBe` "null"
-            it "minified" $ testNull minified
-            it "pretty" $ testNull pretty
-
         context "minified" $ do
+            it "encodes null" $
+                value minified Full.Null `shouldBe` "null"
             it "escapes \\" $
                 value minified (Full.String "\\") `shouldBe` "\"\\\\\""
             it "escapes double quotes" $
@@ -46,113 +42,95 @@ spec = do
                 it "~" $ value minified (Full.String "\x007E") `shouldBe` "\"~\""
 
         context "pretty" $ do
+            it "encodes null" $
+                value pretty Full.Null `shouldBe` "null"
+
             it "uses strings for short string values" $
                 value pretty (Full.String "Short text") `shouldBe` "\"Short text\""
             it "uses block strings for text with new lines, with newline symbol" $
-                let expected = [gql|
-                  """
-                    Line 1
-                    Line 2
-                  """
-                |]
+                let expected = "\"\"\"\n\
+                        \  Line 1\n\
+                        \  Line 2\n\
+                        \\"\"\""
                     actual = value pretty $ Full.String "Line 1\nLine 2"
                  in actual `shouldBe` expected
             it "uses block strings for text with new lines, with CR symbol" $
-                let expected = [gql|
-                  """
-                    Line 1
-                    Line 2
-                  """
-                |]
+                let expected = "\"\"\"\n\
+                        \  Line 1\n\
+                        \  Line 2\n\
+                        \\"\"\""
                     actual = value pretty $ Full.String "Line 1\rLine 2"
                  in actual `shouldBe` expected
             it "uses block strings for text with new lines, with CR symbol followed by newline" $
-                let expected = [gql|
-                  """
-                    Line 1
-                    Line 2
-                  """
-                |]
+                let expected = "\"\"\"\n\
+                        \  Line 1\n\
+                        \  Line 2\n\
+                        \\"\"\""
                     actual = value pretty $ Full.String "Line 1\r\nLine 2"
                  in actual `shouldBe` expected
             it "encodes as one line string if has escaped symbols" $ do
-                let
-                  genNotAllowedSymbol = oneof
+                let genNotAllowedSymbol = oneof
                         [ choose ('\x0000', '\x0008')
                         , choose ('\x000B', '\x000C')
                         , choose ('\x000E', '\x001F')
                         , pure '\x007F'
                         ]
-
                 forAll genNotAllowedSymbol $ \x -> do
-                    let
-                      rawValue = "Short \n" <> Text.Lazy.cons x "text"
-                      encoded = value pretty
-                          $ Full.String $ Text.Lazy.toStrict rawValue
-                    shouldStartWith (Text.Lazy.unpack encoded) "\""
-                    shouldEndWith (Text.Lazy.unpack encoded) "\""
-                    shouldNotContain (Text.Lazy.unpack encoded) "\"\"\""
+                    let rawValue = "Short \n" <> Text.Lazy.cons x "text"
+                        encoded = Text.Lazy.unpack
+                            $ value pretty
+                            $ Full.String
+                            $ Text.Lazy.toStrict rawValue
+                    shouldStartWith encoded "\""
+                    shouldEndWith encoded "\""
+                    shouldNotContain encoded "\"\"\""
 
             it "Hello world" $
                 let actual = value pretty
                         $ Full.String "Hello,\n  World!\n\nYours,\n  GraphQL."
-                    expected = [gql|
-                      """
-                        Hello,
-                          World!
-
-                        Yours,
-                          GraphQL.
-                      """
-                    |]
+                    expected = "\"\"\"\n\
+                        \  Hello,\n\
+                        \    World!\n\
+                        \\n\
+                        \  Yours,\n\
+                        \    GraphQL.\n\
+                        \\"\"\""
                   in actual `shouldBe` expected
 
             it "has only newlines" $
                 let actual = value pretty $ Full.String "\n"
-                    expected = [gql|
-                      """
-
-
-                      """
-                    |]
+                    expected = "\"\"\"\n\n\n\"\"\""
                  in actual `shouldBe` expected
             it "has newlines and one symbol at the begining" $
                 let actual = value pretty $ Full.String "a\n\n"
-                    expected = [gql|
-                      """
-                        a
-
-
-                      """|]
+                    expected = "\"\"\"\n\
+                        \  a\n\
+                        \\n\
+                        \\n\
+                        \\"\"\""
                  in actual `shouldBe` expected
             it "has newlines and one symbol at the end" $
                 let actual = value pretty $ Full.String "\n\na"
-                    expected = [gql|
-                      """
-
-
-                        a
-                      """
-                    |]
+                    expected = "\"\"\"\n\
+                        \\n\
+                        \\n\
+                        \  a\n\
+                        \\"\"\""
                  in actual `shouldBe` expected
             it "has newlines and one symbol in the middle" $
                 let actual = value pretty $ Full.String "\na\n"
-                    expected = [gql|
-                      """
-
-                        a
-
-                      """
-                    |]
+                    expected = "\"\"\"\n\
+                        \\n\
+                        \  a\n\
+                        \\n\
+                        \\"\"\""
                  in actual `shouldBe` expected
             it "skip trailing whitespaces" $
                 let actual = value pretty $ Full.String "  Short\ntext    "
-                    expected = [gql|
-                      """
-                        Short
-                        text
-                      """
-                    |]
+                    expected = "\"\"\"\n\
+                        \  Short\n\
+                        \  text\n\
+                        \\"\"\""
                  in actual `shouldBe` expected
 
     describe "definition" $
@@ -164,14 +142,12 @@ spec = do
                 fieldSelection = pure $ Full.FieldSelection field
                 operation = Full.DefinitionOperation
                     $ Full.SelectionSet fieldSelection location
-                expected = Text.Lazy.snoc [gql|
-                  {
-                    field(message: """
-                      line1
-                      line2
-                    """)
-                  }
-                |] '\n'
+                expected = "{\n\
+                    \  field(message: \"\"\"\n\
+                    \    line1\n\
+                    \    line2\n\
+                    \  \"\"\")\n\
+                    \}\n"
                 actual = definition pretty operation
              in actual `shouldBe` expected
 
@@ -186,12 +162,10 @@ spec = do
                 mutationType = Full.OperationTypeDefinition Full.Mutation "MutationType"
                 operations = queryType :| pure mutationType
                 definition' = Full.SchemaDefinition [] operations
-                expected = Text.Lazy.snoc [gql|
-                  schema {
-                    query: QueryRootType
-                    mutation: MutationType
-                  }
-                |] '\n'
+                expected = "schema {\n\
+                    \  query: QueryRootType\n\
+                    \  mutation: MutationType\n\
+                    \}\n"
                 actual = typeSystemDefinition pretty definition'
              in actual `shouldBe` expected
 
@@ -207,14 +181,12 @@ spec = do
                 argument = Full.InputValueDefinition mempty "arg" someType Nothing mempty
                 arguments = Full.ArgumentsDefinition [argument]
                 definition' = Full.TypeDefinition
-                    $ Full.InterfaceTypeDefinition mempty "UUID" mempty
+                    $ Full.InterfaceTypeDefinition mempty "UUID" (Full.ImplementsInterfaces []) mempty
                     $ pure
                     $ Full.FieldDefinition mempty "value" arguments someType mempty
-                expected = [gql|
-                  interface UUID {
-                    value(arg: String): String
-                  }
-                |]
+                expected = "interface UUID {\n\
+                    \  value(arg: String): String\n\
+                    \}"
                 actual = typeSystemDefinition pretty definition'
              in actual `shouldBe` expected
 
@@ -222,11 +194,9 @@ spec = do
             let definition' = Full.TypeDefinition
                     $ Full.UnionTypeDefinition mempty "SearchResult" mempty
                     $ Full.UnionMemberTypes ["Photo", "Person"]
-                expected = [gql|
-                  union SearchResult =
-                    | Photo
-                    | Person
-                |]
+                expected = "union SearchResult =\n\
+                    \  | Photo\n\
+                    \  | Person"
                 actual = typeSystemDefinition pretty definition'
              in actual `shouldBe` expected
 
@@ -239,14 +209,12 @@ spec = do
                     ]
                 definition' = Full.TypeDefinition
                     $ Full.EnumTypeDefinition mempty "Direction" mempty values
-                expected = [gql|
-                  enum Direction {
-                    NORTH
-                    EAST
-                    SOUTH
-                    WEST
-                  }
-                |]
+                expected = "enum Direction {\n\
+                    \  NORTH\n\
+                    \  EAST\n\
+                    \  SOUTH\n\
+                    \  WEST\n\
+                    \}"
                 actual = typeSystemDefinition pretty definition'
              in actual `shouldBe` expected
 
@@ -259,11 +227,28 @@ spec = do
                     ]
                 definition' = Full.TypeDefinition
                     $ Full.InputObjectTypeDefinition mempty "ExampleInputObject" mempty fields
-                expected = [gql|
-                  input ExampleInputObject {
-                    a: String
-                    b: Int!
-                  }
-                |]
+                expected = "input ExampleInputObject {\n\
+                    \  a: String\n\
+                    \  b: Int!\n\
+                    \}"
+                actual = typeSystemDefinition pretty definition'
+             in actual `shouldBe` expected
+
+        context "directive definition" $ do
+            it "encodes a directive definition" $ do
+                let definition' = Full.DirectiveDefinition mempty "example" mempty False
+                        $ pure
+                        $ DirectiveLocation.ExecutableDirectiveLocation DirectiveLocation.Field
+                    expected = "@example() on\n\
+                        \  | FIELD"
+                    actual = typeSystemDefinition pretty definition'
+                 in actual `shouldBe` expected
+
+            it "encodes a repeatable directive definition" $ do
+                let definition' = Full.DirectiveDefinition mempty "example" mempty True
+                        $ pure
+                        $ DirectiveLocation.ExecutableDirectiveLocation DirectiveLocation.Field
+                    expected = "@example() repeatable on\n\
+                        \  | FIELD"
                     actual = typeSystemDefinition pretty definition'
                  in actual `shouldBe` expected

tests/Language/GraphQL/AST/LexerSpec.hs

@@ -1,5 +1,4 @@
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE QuasiQuotes #-}
 module Language.GraphQL.AST.LexerSpec
     ( spec
     ) where
@@ -7,7 +6,6 @@ module Language.GraphQL.AST.LexerSpec
 import Data.Text (Text)
 import Data.Void (Void)
 import Language.GraphQL.AST.Lexer
-import Language.GraphQL.TH
 import Test.Hspec (Spec, context, describe, it)
 import Test.Hspec.Megaparsec (shouldParse, shouldFailOn, shouldSucceedOn)
 import Text.Megaparsec (ParseErrorBundle, parse)
@@ -19,38 +17,39 @@ spec = describe "Lexer" $ do
             parse unicodeBOM "" `shouldSucceedOn` "\xfeff"
 
         it "lexes strings" $ do
-            parse string "" [gql|"simple"|] `shouldParse` "simple"
-            parse string "" [gql|" white space "|] `shouldParse` " white space "
-            parse string "" [gql|"quote \""|] `shouldParse` [gql|quote "|]
-            parse string "" [gql|"escaped \n"|] `shouldParse` "escaped \n"
-            parse string "" [gql|"slashes \\ \/"|] `shouldParse` [gql|slashes \ /|]
-            parse string "" [gql|"unicode \u1234\u5678\u90AB\uCDEF"|]
+            parse string "" "\"simple\"" `shouldParse` "simple"
+            parse string "" "\" white space \"" `shouldParse` " white space "
+            parse string "" "\"quote \\\"\"" `shouldParse` "quote \""
+            parse string "" "\"escaped \\n\"" `shouldParse` "escaped \n"
+            parse string "" "\"slashes \\\\ \\/\"" `shouldParse` "slashes \\ /"
+            parse string "" "\"unicode \\u1234\\u5678\\u90AB\\uCDEF\""
                 `shouldParse` "unicode ሴ噸邫췯"
 
         it "lexes block string" $ do
-            parse blockString "" [gql|"""simple"""|] `shouldParse` "simple"
-            parse blockString "" [gql|""" white space """|]
+            parse blockString "" "\"\"\"simple\"\"\"" `shouldParse` "simple"
+            parse blockString "" "\"\"\" white space \"\"\""
                 `shouldParse` " white space "
-            parse blockString "" [gql|"""contains " quote"""|]
-                `shouldParse` [gql|contains " quote|]
-            parse blockString "" [gql|"""contains \""" triplequote"""|]
-                `shouldParse` [gql|contains """ triplequote|]
+            parse blockString "" "\"\"\"contains \" quote\"\"\""
+                `shouldParse` "contains \" quote"
+            parse blockString "" "\"\"\"contains \\\"\"\" triplequote\"\"\""
+                `shouldParse` "contains \"\"\" triplequote"
             parse blockString "" "\"\"\"multi\nline\"\"\"" `shouldParse` "multi\nline"
             parse blockString "" "\"\"\"multi\rline\r\nnormalized\"\"\""
                 `shouldParse` "multi\nline\nnormalized"
             parse blockString "" "\"\"\"multi\rline\r\nnormalized\"\"\""
                 `shouldParse` "multi\nline\nnormalized"
-            parse blockString "" [gql|"""unescaped \n\r\b\t\f\u1234"""|]
-                `shouldParse` [gql|unescaped \n\r\b\t\f\u1234|]
-            parse blockString "" [gql|"""slashes \\ \/"""|]
-                `shouldParse` [gql|slashes \\ \/|]
-            parse blockString "" [gql|"""
-
-                spans
-                  multiple
-                    lines
-
-                """|] `shouldParse` "spans\n  multiple\n    lines"
+            parse blockString "" "\"\"\"unescaped \\n\\r\\b\\t\\f\\u1234\"\"\""
+                `shouldParse` "unescaped \\n\\r\\b\\t\\f\\u1234"
+            parse blockString "" "\"\"\"slashes \\\\ \\/\"\"\""
+                `shouldParse` "slashes \\\\ \\/"
+            parse blockString "" "\"\"\"\n\
+                \\n\
+                \  spans\n\
+                \    multiple\n\
+                \      lines\n\
+                \\n\
+                \\"\"\""
+                `shouldParse` "spans\n  multiple\n    lines"
 
         it "lexes numbers" $ do
             parse integer "" "4" `shouldParse` (4 :: Int)
@@ -84,7 +83,7 @@ spec = describe "Lexer" $ do
 
     context "Implementation tests" $ do
         it "lexes empty block strings" $
-            parse blockString "" [gql|""""""|] `shouldParse` ""
+            parse blockString "" "\"\"\"\"\"\"" `shouldParse` ""
         it "lexes ampersand" $
             parse amp "" "&" `shouldParse` "&"
         it "lexes schema extensions" $

tests/Language/GraphQL/AST/ParserSpec.hs

@@ -1,18 +1,20 @@
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE QuasiQuotes #-}
 module Language.GraphQL.AST.ParserSpec
     ( spec
     ) where
 
 import Data.List.NonEmpty (NonEmpty(..))
-import Data.Text (Text)
 import qualified Data.Text as Text
 import Language.GraphQL.AST.Document
 import qualified Language.GraphQL.AST.DirectiveLocation as DirLoc
 import Language.GraphQL.AST.Parser
-import Language.GraphQL.TH
 import Test.Hspec (Spec, describe, it, context)
-import Test.Hspec.Megaparsec (shouldParse, shouldFailOn, shouldSucceedOn)
+import Test.Hspec.Megaparsec
+    ( shouldParse
+    , shouldFailOn
+    , parseSatisfies
+    , shouldSucceedOn
+    )
 import Text.Megaparsec (parse)
 import Test.QuickCheck (property, NonEmptyList (..), mapSize)
 import Language.GraphQL.AST.Arbitrary
@@ -24,181 +26,159 @@ spec = describe "Parser" $ do
 
     context "Arguments" $ do
         it "accepts block strings as argument" $
-           parse document "" `shouldSucceedOn` [gql|{
-                 hello(text: """Argument""")
-               }|]
+            parse document "" `shouldSucceedOn`
+                "{ hello(text: \"\"\"Argument\"\"\") }"
 
         it "accepts strings as argument" $
-           parse document "" `shouldSucceedOn` [gql|{
-                 hello(text: "Argument")
-               }|]
+            parse document "" `shouldSucceedOn` "{ hello(text: \"Argument\") }"
 
-       it "accepts int as argument1" $
-           parse document "" `shouldSucceedOn` [gql|{
-                 user(id: 4)
-               }|]
+        it "accepts int as argument" $
+            parse document "" `shouldSucceedOn` "{ user(id: 4) }"
 
         it "accepts boolean as argument" $
-           parse document "" `shouldSucceedOn` [gql|{
-                 hello(flag: true) { field1 }
-               }|]
+            parse document "" `shouldSucceedOn`
+                "{ hello(flag: true) { field1 } }"
 
         it "accepts float as argument" $
-           parse document "" `shouldSucceedOn` [gql|{
-                 body(height: 172.5) { height }
-               }|]
+            parse document "" `shouldSucceedOn`
+                "{ body(height: 172.5) { height } }"
 
         it "accepts empty list as argument" $
-           parse document "" `shouldSucceedOn` [gql|{
-                 query(list: []) { field1 }
-               }|]
+            parse document "" `shouldSucceedOn` "{ query(list: []) { field1 } }"
 
         it "accepts two required arguments" $
-           parse document "" `shouldSucceedOn` [gql|
-               mutation auth($username: String!, $password: String!){
-                 test
-               }|]
+            parse document "" `shouldSucceedOn`
+                "mutation auth($username: String!, $password: String!) { test }"
 
         it "accepts two string arguments" $
-           parse document "" `shouldSucceedOn` [gql|
-               mutation auth{
-                 test(username: "username", password: "password")
-               }|]
+            parse document "" `shouldSucceedOn`
+                "mutation auth { test(username: \"username\", password: \"password\") }"
 
         it "accepts two block string arguments" $
-           parse document "" `shouldSucceedOn` [gql|
-               mutation auth{
-                 test(username: """username""", password: """password""")
-               }|]
+            let given = "mutation auth {\n\
+                    \  test(username: \"\"\"username\"\"\", password: \"\"\"password\"\"\")\n\
+                    \}"
+             in parse document "" `shouldSucceedOn` given
+
+        it "fails to parse an empty argument list in parens" $
+            parse document "" `shouldFailOn` "{ test() }"
 
         it "accepts any arguments" $ mapSize (const 10) $ property $ \xs ->
-            let
-                query' :: Text
-                arguments = map printArgument $ getNonEmpty (xs :: NonEmptyList (AnyArgument AnyValue))
-                query' = "query(" <> Text.intercalate ", " arguments <> ")" in
-            parse document "" `shouldSucceedOn` ("{ " <> query' <> " }")
+            let arguments' = map printArgument
+                    $ getNonEmpty (xs :: NonEmptyList (AnyArgument AnyValue))
+                query' = "query(" <> Text.intercalate ", " arguments' <> ")"
+             in parse document "" `shouldSucceedOn` ("{ " <> query' <> " }")
 
     it "parses minimal schema definition" $
-        parse document "" `shouldSucceedOn` [gql|schema { query: Query }|]
+        parse document "" `shouldSucceedOn` "schema { query: Query }"
 
     it "parses minimal scalar definition" $
-        parse document "" `shouldSucceedOn` [gql|scalar Time|]
+        parse document "" `shouldSucceedOn` "scalar Time"
 
     it "parses ImplementsInterfaces" $
-        parse document "" `shouldSucceedOn` [gql|
-            type Person implements NamedEntity & ValuedEntity {
-              name: String
-            }
-        |]
+        parse document "" `shouldSucceedOn`
+            "type Person implements NamedEntity & ValuedEntity {\n\
+            \  name: String\n\
+            \}"
 
     it "parses a  type without ImplementsInterfaces" $
-        parse document "" `shouldSucceedOn` [gql|
-            type Person {
-              name: String
-            }
-        |]
+        parse document "" `shouldSucceedOn`
+            "type Person {\n\
+            \  name: String\n\
+            \}"
 
     it "parses ArgumentsDefinition in an ObjectDefinition" $
-        parse document "" `shouldSucceedOn` [gql|
-            type Person {
-              name(first: String, last: String): String
-            }
-        |]
+        parse document "" `shouldSucceedOn`
+            "type Person {\n\
+            \  name(first: String, last: String): String\n\
+            \}"
 
     it "parses minimal union type definition" $
-        parse document "" `shouldSucceedOn` [gql|
-            union SearchResult = Photo | Person
-        |]
+        parse document "" `shouldSucceedOn`
+            "union SearchResult = Photo | Person"
 
     it "parses minimal interface type definition" $
-        parse document "" `shouldSucceedOn` [gql|
-            interface NamedEntity {
-              name: String
-            }
-        |]
+        parse document "" `shouldSucceedOn`
+            "interface NamedEntity {\n\
+            \  name: String\n\
+            \}"
+
+    it "parses ImplementsInterfaces on interfaces" $
+        parse document "" `shouldSucceedOn`
+            "interface Person implements NamedEntity & ValuedEntity {\n\
+            \  name: String\n\
+            \}"
 
     it "parses minimal enum type definition" $
-        parse document "" `shouldSucceedOn` [gql|
-            enum Direction {
-              NORTH
-              EAST
-              SOUTH
-              WEST
-            }
-        |]
+        parse document "" `shouldSucceedOn`
+            "enum Direction {\n\
+            \  NORTH\n\
+            \  EAST\n\
+            \  SOUTH\n\
+            \  WEST\n\
+            \}"
 
     it "parses minimal input object type definition" $
-        parse document "" `shouldSucceedOn` [gql|
-            input Point2D {
-              x: Float
-              y: Float
-            }
-        |]
+        parse document "" `shouldSucceedOn`
+            "input Point2D {\n\
+            \  x: Float\n\
+            \  y: Float\n\
+            \}"
 
     it "parses minimal input enum definition with an optional pipe" $
-        parse document "" `shouldSucceedOn` [gql|
-            directive @example on
-              | FIELD
-              | FRAGMENT_SPREAD
-        |]
+        parse document "" `shouldSucceedOn`
+            "directive @example on\n\
+            \  | FIELD\n\
+            \  | FRAGMENT_SPREAD"
 
     it "parses two minimal directive definitions" $
-        let directive nm loc =
-                TypeSystemDefinition
-                    (DirectiveDefinition
+        let directive name' loc = TypeSystemDefinition
+                $ DirectiveDefinition
                     (Description Nothing)
-                         nm
+                    name'
                     (ArgumentsDefinition [])
-                         (loc :| []))
-            example1 =
-                directive "example1"
+                    False
+                    (loc :| [])
+            example1 = directive "example1"
                 (DirLoc.TypeSystemDirectiveLocation DirLoc.FieldDefinition)
                 (Location {line = 1, column = 1})
-            example2 =
-                directive "example2"
+            example2 = directive "example2"
                 (DirLoc.ExecutableDirectiveLocation DirLoc.Field)
                 (Location {line = 2, column = 1})
-            testSchemaExtension = example1 :| [ example2 ]
-            query = [gql|
-              directive @example1 on FIELD_DEFINITION
-              directive @example2 on FIELD
-            |]
+            testSchemaExtension = example1 :| [example2]
+            query = Text.unlines
+                [ "directive @example1 on FIELD_DEFINITION"
+                , "directive @example2 on FIELD"
+                ]
          in parse document "" query `shouldParse` testSchemaExtension
 
     it "parses a directive definition with a default empty list argument" $
-        let directive nm loc args =
-                TypeSystemDefinition
-                    (DirectiveDefinition
-                         (Description Nothing)
-                         nm
-                         (ArgumentsDefinition
-                              [ InputValueDefinition
-                                    (Description Nothing)
-                                    argName
-                                    argType
-                                    argValue
-                                    []
-                              | (argName, argType, argValue) <- args])
-                         (loc :| []))
-            defn =
-                directive "test"
-                    (DirLoc.TypeSystemDirectiveLocation DirLoc.FieldDefinition)
-                    [("foo",
-                      TypeList (TypeNamed "String"),
-                      Just
+        let argumentValue = Just
                 $ Node (ConstList [])
-                          $ Location {line = 1, column = 33})]
-                    (Location {line = 1, column = 1})
-            query = [gql|directive @test(foo: [String] = []) on FIELD_DEFINITION|]
-         in parse document "" query `shouldParse` (defn :| [ ])
+                $ Location{ line = 1, column = 33 }
+            loc = DirLoc.TypeSystemDirectiveLocation DirLoc.FieldDefinition
+            argumentValueDefinition = InputValueDefinition
+                (Description Nothing)
+                "foo"
+                (TypeList (TypeNamed "String"))
+                argumentValue
+                []
+            definition = DirectiveDefinition
+                (Description Nothing)
+                "test"
+                (ArgumentsDefinition [argumentValueDefinition])
+                False
+                (loc :| [])
+            directive = TypeSystemDefinition definition
+                $ Location{ line = 1, column = 1 }
+            query = "directive @test(foo: [String] = []) on FIELD_DEFINITION"
+         in parse document "" query `shouldParse` (directive :| [])
 
     it "parses schema extension with a new directive" $
-        parse document "" `shouldSucceedOn`[gql|
-            extend schema @newDirective
-        |]
+        parse document "" `shouldSucceedOn` "extend schema @newDirective"
 
     it "parses schema extension with an operation type definition" $
-        parse document "" `shouldSucceedOn` [gql|extend schema { query: Query }|]
+        parse document "" `shouldSucceedOn` "extend schema { query: Query }"
 
     it "parses schema extension with an operation type and directive" $
         let newDirective = Directive "newDirective" [] $ Location 1 15
@@ -207,45 +187,42 @@ spec = describe "Parser" $ do
                 $ OperationTypeDefinition Query "Query" :| []
             testSchemaExtension = TypeSystemExtension schemaExtension
                 $ Location 1 1
-            query = [gql|extend schema @newDirective { query: Query }|]
+            query = "extend schema @newDirective { query: Query }"
          in parse document "" query `shouldParse` (testSchemaExtension :| [])
 
+    it "parses a repeatable directive definition" $
+        let given = "directive @test repeatable on FIELD_DEFINITION"
+            isRepeatable (TypeSystemDefinition definition' _ :| [])
+                | DirectiveDefinition _ _ _ repeatable _ <- definition' = repeatable
+            isRepeatable _ = False
+         in parse document "" given `parseSatisfies` isRepeatable
+
     it "parses an object extension" $
-        parse document "" `shouldSucceedOn` [gql|
-            extend type Story {
-              isHiddenLocally: Boolean
-            }
-        |]
+        parse document "" `shouldSucceedOn`
+            "extend type Story { isHiddenLocally: Boolean }"
 
     it "rejects variables in DefaultValue" $
-        parse document "" `shouldFailOn` [gql|
-            query ($book: String = "Zarathustra", $author: String = $book) {
-              title
-            }
-        |]
+        parse document "" `shouldFailOn`
+            "query ($book: String = \"Zarathustra\", $author: String = $book) {\n\
+            \  title\n\
+            \}"
 
     it "rejects empty selection set" $
-       parse document "" `shouldFailOn` [gql|
-            query {
-              innerField {}
-            }
-        |]
+       parse document "" `shouldFailOn` "query { innerField {} }"
 
     it "parses documents beginning with a comment" $
-        parse document "" `shouldSucceedOn` [gql|
-            """
-            Query
-            """
-            type Query {
-                queryField: String
-            }
-        |]
+        parse document "" `shouldSucceedOn`
+            "\"\"\"\n\
+            \Query\n\
+            \\"\"\"\n\
+            \type Query {\n\
+            \  queryField: String\n\
+            \}"
 
     it "parses subscriptions" $
-        parse document "" `shouldSucceedOn` [gql|
-            subscription NewMessages {
-              newMessage(roomId: 123) {
-                sender
-              }
-            }
-        |]
+        parse document "" `shouldSucceedOn`
+            "subscription NewMessages {\n\
+            \  newMessage(roomId: 123) {\n\
+            \    sender\n\
+            \  }\n\
+            \}"

tests/Language/GraphQL/ExecuteSpec.hs

@@ -5,9 +5,7 @@
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE QuasiQuotes #-}
 
 module Language.GraphQL.ExecuteSpec
     ( spec
@@ -23,7 +21,6 @@ import Language.GraphQL.AST (Document, Location(..), Name)
 import Language.GraphQL.AST.Parser (document)
 import Language.GraphQL.Error
 import Language.GraphQL.Execute (execute)
-import Language.GraphQL.TH
 import qualified Language.GraphQL.Type.Schema as Schema
 import qualified Language.GraphQL.Type as Type
 import Language.GraphQL.Type
@@ -69,6 +66,7 @@ queryType = Out.ObjectType "Query" Nothing []
     , ("throwing", ValueResolver throwingField throwingResolver)
     , ("count", ValueResolver countField countResolver)
     , ("sequence", ValueResolver sequenceField sequenceResolver)
+    , ("withInputObject", ValueResolver withInputObjectField withInputObjectResolver)
     ]
   where
     philosopherField =
@@ -89,6 +87,17 @@ queryType = Out.ObjectType "Query" Nothing []
         let fieldType = Out.ListType $ Out.NonNullScalarType int
          in Out.Field Nothing fieldType HashMap.empty
     sequenceResolver = pure intSequence
+    withInputObjectResolver = pure $ Type.Int 0
+    withInputObjectField =
+        Out.Field Nothing (Out.NonNullScalarType int) $ HashMap.fromList
+            [("values", In.Argument Nothing withInputObjectArgumentType Nothing)]
+    withInputObjectArgumentType = In.NonNullListType
+        $ In.NonNullInputObjectType inputObjectType
+
+inputObjectType :: In.InputObjectType
+inputObjectType = In.InputObjectType "InputObject" Nothing $
+    HashMap.singleton "name" $
+        In.InputField Nothing (In.NonNullScalarType int) Nothing
 
 intSequence :: Value
 intSequence = Type.List [Type.Int 1, Type.Int 2, Type.Int 3]
@@ -257,15 +266,15 @@ spec :: Spec
 spec =
     describe "execute" $ do
         it "rejects recursive fragments" $
-            let sourceQuery = [gql|
-              {
-                ...cyclicFragment
-              }
-
-              fragment cyclicFragment on Query {
-                ...cyclicFragment
-              }
-            |]
+            let sourceQuery = "\
+              \{\n\
+              \  ...cyclicFragment\n\
+              \}\n\
+              \\n\
+              \fragment cyclicFragment on Query {\n\
+              \  ...cyclicFragment\n\
+              \}\
+              \"
                 expected = Response (Object mempty) mempty
              in sourceQuery `shouldResolveTo` expected
 
@@ -295,7 +304,7 @@ spec =
                 let data'' = Object $ HashMap.singleton "philosopher" Null
                     executionErrors = pure $ Error
                         { message =
-                            "Value completion error. Expected type !School, found: EXISTENTIALISM."
+                            "Value completion error. Expected type School!, found: EXISTENTIALISM."
                         , locations = [Location 1 17]
                         , path = [Segment "philosopher", Segment "school"]
                         }
@@ -307,7 +316,7 @@ spec =
                 let data'' = Object $ HashMap.singleton "philosopher" Null
                     executionErrors = pure $ Error
                         { message =
-                            "Value completion error. Expected type !Interest, found: { instrument: \"piano\" }."
+                            "Value completion error. Expected type Interest!, found: { instrument: \"piano\" }."
                         , locations = [Location 1 17]
                         , path = [Segment "philosopher", Segment "interest"]
                         }
@@ -319,7 +328,7 @@ spec =
                 let data'' = Object $ HashMap.singleton "philosopher" Null
                     executionErrors = pure $ Error
                         { message
-                            = "Value completion error. Expected type !Work, found:\
+                            = "Value completion error. Expected type Work!, found:\
                             \ { title: \"Also sprach Zarathustra: Ein Buch f\252r Alle und Keinen\" }."
                         , locations = [Location 1 17]
                         , path = [Segment "philosopher", Segment "majorWork"]
@@ -328,22 +337,10 @@ spec =
                     sourceQuery = "{ philosopher { majorWork { title } } }"
                  in sourceQuery `shouldResolveTo` expected
 
-            it "gives location information for invalid scalar arguments" $
-                let data'' = Object $ HashMap.singleton "philosopher" Null
-                    executionErrors = pure $ Error
-                        { message =
-                            "Argument \"id\" has invalid type. Expected type ID, found: True."
-                        , locations = [Location 1 15]
-                        , path = [Segment "philosopher"]
-                        }
-                    expected = Response data'' executionErrors
-                    sourceQuery = "{ philosopher(id: true) { lastName } }"
-                 in sourceQuery `shouldResolveTo` expected
-
             it "gives location information for failed result coercion" $
                 let data'' = Object $ HashMap.singleton "philosopher" Null
                     executionErrors = pure $ Error
-                        { message = "Unable to coerce result to !Int."
+                        { message = "Unable to coerce result to Int!."
                         , locations = [Location 1 26]
                         , path = [Segment "philosopher", Segment "century"]
                         }
@@ -364,7 +361,7 @@ spec =
 
             it "sets data to null if a root field isn't nullable" $
                 let executionErrors = pure $ Error
-                        { message = "Unable to coerce result to !Int."
+                        { message = "Unable to coerce result to Int!."
                         , locations = [Location 1 3]
                         , path = [Segment "count"]
                         }
@@ -375,7 +372,7 @@ spec =
             it "detects nullability errors" $
                 let data'' = Object $ HashMap.singleton "philosopher" Null
                     executionErrors = pure $ Error
-                        { message = "Value completion error. Expected type !String, found: null."
+                        { message = "Value completion error. Expected type String!, found: null."
                         , locations = [Location 1 26]
                         , path = [Segment "philosopher", Segment "firstLanguage"]
                         }
@@ -389,6 +386,25 @@ spec =
                     sourceQuery = "{ sequence }"
                 in sourceQuery `shouldResolveTo` expected
 
+            context "Arguments" $ do
+                it "gives location information for invalid scalar arguments" $
+                    let data'' = Object $ HashMap.singleton "philosopher" Null
+                        executionErrors = pure $ Error
+                            { message =
+                                "Argument \"id\" has invalid type. Expected type ID, found: True."
+                            , locations = [Location 1 15]
+                            , path = [Segment "philosopher"]
+                            }
+                        expected = Response data'' executionErrors
+                        sourceQuery = "{ philosopher(id: true) { lastName } }"
+                    in sourceQuery `shouldResolveTo` expected
+
+                it "puts an object in a list if needed" $
+                    let data'' = Object $ HashMap.singleton "withInputObject" $ Type.Int 0
+                        expected = Response data'' mempty
+                        sourceQuery = "{ withInputObject(values: { name: 0 }) }"
+                    in sourceQuery `shouldResolveTo` expected
+
             context "queryError" $ do
                 let namedQuery name = "query " <> name <> " { philosopher(id: \"1\") { interest } }"
                     twoQueries = namedQuery "A" <> " " <> namedQuery "B"

tests/Language/GraphQL/THSpec.hs

@@ -1,23 +0,0 @@
-{- 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 QuasiQuotes #-}
-
-module Language.GraphQL.THSpec
-    ( spec
-    ) where
-
-import Language.GraphQL.TH (gql)
-import Test.Hspec (Spec, describe, it, shouldBe)
-
-spec :: Spec
-spec =
-    describe "gql" $
-        it "replaces CRNL with NL" $
-            let expected = "line1\nline2"
-                actual = [gql|
-                  line1
-                  line2
-                |]
-             in actual `shouldBe` expected