graphql 1.3.0.0 → 1.4.0.0
raw patch · 21 files changed
+833/−853 lines, 21 filesdep ~basePVP ok
version bump matches the API change (PVP)
Dependency ranges changed: base
API changes (from Hackage documentation)
+ Language.GraphQL.AST.Document: [$sel:arguments:Directive] :: Directive -> [Argument]
+ Language.GraphQL.AST.Document: [$sel:location:Directive] :: Directive -> Location
+ Language.GraphQL.AST.Document: [$sel:name:Directive] :: Directive -> Name
+ Language.GraphQL.Type.In: instance GHC.Classes.Eq Language.GraphQL.Type.In.Argument
- Language.GraphQL.AST.Document: DirectiveDefinition :: Description -> Name -> ArgumentsDefinition -> NonEmpty DirectiveLocation -> TypeSystemDefinition
+ Language.GraphQL.AST.Document: DirectiveDefinition :: Description -> Name -> ArgumentsDefinition -> Bool -> NonEmpty DirectiveLocation -> TypeSystemDefinition
- Language.GraphQL.Type.Schema: Directive :: Maybe Text -> [DirectiveLocation] -> Arguments -> Directive
+ Language.GraphQL.Type.Schema: Directive :: Maybe Text -> Arguments -> Bool -> [DirectiveLocation] -> Directive
Files
- CHANGELOG.md +15/−0
- graphql.cabal +5/−5
- src/Language/GraphQL/AST/DirectiveLocation.hs +1/−1
- src/Language/GraphQL/AST/Document.hs +6/−2
- src/Language/GraphQL/AST/Encoder.hs +3/−2
- src/Language/GraphQL/AST/Lexer.hs +41/−39
- src/Language/GraphQL/AST/Parser.hs +3/−1
- src/Language/GraphQL/Execute/Coerce.hs +1/−1
- src/Language/GraphQL/TH.hs +14/−4
- src/Language/GraphQL/Type/In.hs +1/−0
- src/Language/GraphQL/Type/Internal.hs +5/−1
- src/Language/GraphQL/Type/Schema.hs +15/−5
- src/Language/GraphQL/Validate.hs +4/−4
- src/Language/GraphQL/Validate/Rules.hs +41/−34
- tests/Language/GraphQL/AST/Arbitrary.hs +44/−16
- tests/Language/GraphQL/AST/EncoderSpec.hs +104/−119
- tests/Language/GraphQL/AST/LexerSpec.hs +25/−26
- tests/Language/GraphQL/AST/ParserSpec.hs +145/−174
- tests/Language/GraphQL/ExecuteSpec.hs +9/−12
- tests/Language/GraphQL/THSpec.hs +24/−0
- tests/Language/GraphQL/Validate/RulesSpec.hs +327/−407
CHANGELOG.md view
@@ -6,6 +6,20 @@ and this project adheres to [Haskell Package Versioning Policy](https://pvp.haskell.org/). +## [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@@ -524,6 +538,7 @@ ### Added - Data types for the GraphQL language. +[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
graphql.cabal view
@@ -1,7 +1,7 @@-cabal-version: 2.4+cabal-version: 3.0 name: graphql-version: 1.3.0.0+version: 1.4.0.0 synopsis: Haskell GraphQL implementation description: Haskell <https://spec.graphql.org/June2018/ GraphQL> implementation. category: Language@@ -21,8 +21,7 @@ CHANGELOG.md README.md tested-with:- GHC == 9.4.7,- GHC == 9.6.3+ GHC == 9.8.2 source-repository head type: git@@ -58,7 +57,7 @@ ghc-options: -Wall build-depends:- base >= 4.7 && < 5,+ base >= 4.15 && < 5, conduit ^>= 1.3.4, containers >= 0.6 && < 0.8, exceptions ^>= 0.10.4,@@ -85,6 +84,7 @@ Language.GraphQL.Execute.CoerceSpec Language.GraphQL.Execute.OrderedMapSpec Language.GraphQL.ExecuteSpec+ Language.GraphQL.THSpec Language.GraphQL.Type.OutSpec Language.GraphQL.Validate.RulesSpec Schemas.HeroSchema
src/Language/GraphQL/AST/DirectiveLocation.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE Safe #-} --- | Various parts of a GraphQL document can be annotated with directives. +-- | Various parts of a GraphQL document can be annotated with directives. -- This module describes locations in a document where directives can appear. module Language.GraphQL.AST.DirectiveLocation ( DirectiveLocation(..)
src/Language/GraphQL/AST/Document.hs view
@@ -380,7 +380,11 @@ -- -- 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 @@ = SchemaDefinition [Directive] (NonEmpty OperationTypeDefinition) | TypeDefinition TypeDefinition | DirectiveDefinition- Description Name ArgumentsDefinition (NonEmpty DirectiveLocation)+ Description Name ArgumentsDefinition Bool (NonEmpty DirectiveLocation) deriving (Eq, Show) -- ** Type System Extensions
src/Language/GraphQL/AST/Encoder.hs view
@@ -159,11 +159,12 @@ <> 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) @@ -276,7 +277,7 @@ pipeList Minified = (" " <>) . Lazy.Text.intercalate " | " . toList pipeList (Pretty _) = Lazy.Text.concat . fmap (("\n" <> indentSymbol <> "| ") <>)- . toList + . toList enumValueDefinition :: Formatter -> Full.EnumValueDefinition -> Lazy.Text enumValueDefinition (Pretty _) enumValue =
src/Language/GraphQL/AST/Lexer.hs view
@@ -29,7 +29,8 @@ , 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,22 +38,22 @@ import Data.List.NonEmpty (NonEmpty(..)) import Data.Proxy (Proxy(..)) import Data.Void (Void)-import Text.Megaparsec ( Parsec- , (<?>)- , between- , chunk- , chunkToTokens- , notFollowedBy- , oneOf- , option- , optional- , satisfy- , sepBy- , skipSome- , takeP- , takeWhile1P- , try- )+import Text.Megaparsec+ ( Parsec+ , (<?>)+ , between+ , chunk+ , chunkToTokens+ , notFollowedBy+ , oneOf+ , option+ , optional+ , satisfy+ , skipSome+ , takeP+ , takeWhile1P+ , try+ ) import Text.Megaparsec.Char (char, digitChar, space1) import qualified Text.Megaparsec.Char.Lexer as Lexer import Data.Text (Text)@@ -142,12 +143,13 @@ 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,10 +182,10 @@ name = do firstLetter <- nameFirstLetter rest <- many $ nameFirstLetter <|> digitChar- _ <- spaceConsumer- return $ TL.toStrict $ TL.cons firstLetter $ TL.pack rest- where- nameFirstLetter = satisfy isAsciiUpper <|> satisfy isAsciiLower <|> char '_'+ void spaceConsumer+ pure $ TL.toStrict $ TL.cons firstLetter $ TL.pack rest+ where+ nameFirstLetter = satisfy isAsciiUpper <|> satisfy isAsciiLower <|> char '_' isChunkDelimiter :: Char -> Bool isChunkDelimiter = flip notElem ['"', '\\', '\n', '\r']@@ -197,25 +199,25 @@ 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- . chunkToTokens (Proxy :: Proxy T.Text)- <$> takeP Nothing 4- _ -> return escaped+ '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+ _ -> pure escaped where step accumulator = (accumulator * 16 +) . digitToInt
src/Language/GraphQL/AST/Parser.hs view
@@ -8,7 +8,7 @@ ( 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 @@ , unPos , (<?>) )+import Data.Maybe (isJust) -- | Parser for the GraphQL documents. document :: Parser Full.Document@@ -82,6 +83,7 @@ <* at <*> name <*> argumentsDefinition+ <*> (isJust <$> optional (symbol "repeatable")) <* symbol "on" <*> directiveLocations <?> "DirectiveDefinition"
src/Language/GraphQL/Execute/Coerce.hs view
@@ -147,7 +147,7 @@ | member enumValue type' = Just $ Type.Enum enumValue where member value (Type.EnumType _ _ members) = HashMap.member value members-coerceInputLiteral (In.InputObjectBaseType type') (Type.Object values) = +coerceInputLiteral (In.InputObjectBaseType type') (Type.Object values) = let (In.InputObjectType _ _ inputFields) = type' in Type.Object <$> HashMap.foldrWithKey (matchFieldValues' values) (Just HashMap.empty) inputFields
src/Language/GraphQL/TH.hs view
@@ -12,20 +12,30 @@ stripIndentation :: String -> String stripIndentation code = reverse- $ dropNewlines+ $ dropWhile isLineBreak $ reverse $ unlines- $ indent spaces <$> lines withoutLeadingNewlines+ $ indent spaces <$> lines' withoutLeadingNewlines where indent 0 xs = xs indent count (' ' : xs) = indent (count - 1) xs indent _ xs = xs- withoutLeadingNewlines = dropNewlines code- dropNewlines = dropWhile $ flip any ['\n', '\r'] . (==)+ 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.+{-# DEPRECATED gql "Use Language.GraphQL.Class.gql from graphql-spice instead" #-} gql :: QuasiQuoter gql = QuasiQuoter { quoteExp = pure . LitE . StringL . stripIndentation
src/Language/GraphQL/Type/In.hs view
@@ -74,6 +74,7 @@ -- | 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 view
@@ -48,7 +48,11 @@ 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/Schema.hs view
@@ -85,15 +85,16 @@ [ ("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 @@ , 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 @@ , 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 view
@@ -200,7 +200,7 @@ 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@@ -283,7 +283,7 @@ schema' = Validation.schema context queryRoot = Just $ Out.NamedObjectType $ Schema.query schema' types' = Schema.types schema'- + typeToOut :: forall m. Schema.Type m -> Maybe (Out.Type m) typeToOut (Schema.ObjectType objectType) = Just $ Out.NamedObjectType objectType@@ -403,7 +403,7 @@ -> Seq (Validation.RuleT m) arguments rule argumentTypes = foldMap forEach . Seq.fromList where- forEach argument'@(Full.Argument argumentName _ _) = + forEach argument'@(Full.Argument argumentName _ _) = let argumentType = HashMap.lookup argumentName argumentTypes in argument rule argumentType argument' @@ -482,4 +482,4 @@ $ 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 view
@@ -50,14 +50,15 @@ 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@@ -253,14 +254,16 @@ -> 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' }@@ -530,16 +533,20 @@ -- 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"- where- extract (Full.Directive directiveName _ location') =- (directiveName, location')--groupSorted :: forall a. (a -> Text) -> [a] -> [[a]]-groupSorted getName = groupBy equalByName . sortOn getName+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- 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))@@ -549,12 +556,12 @@ 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 "@@ -833,7 +840,7 @@ . 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@@ -854,18 +861,18 @@ 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 \"@"@@ -913,7 +920,7 @@ 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]@@ -943,7 +950,7 @@ 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@@ -1411,7 +1418,7 @@ 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 view
@@ -1,15 +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']@@ -20,30 +31,42 @@ instance Arbitrary AnyPrintableChar where arbitrary = AnyPrintableChar <$> elements chars where- chars = alpha <> num <> ['_'] + 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@@ -51,7 +74,9 @@ 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@@ -60,8 +85,9 @@ 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@@ -88,8 +114,9 @@ , Doc.Object <$> objectGen ] -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@@ -99,4 +126,5 @@ 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 view
@@ -1,5 +1,4 @@ {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes #-} module Language.GraphQL.AST.EncoderSpec ( spec ) where@@ -7,20 +6,17 @@ 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 @@ 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- [ choose ('\x0000', '\x0008')- , choose ('\x000B', '\x000C')- , choose ('\x000E', '\x001F')- , pure '\x007F'- ]-+ 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 @@ 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 @@ 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 @@ -210,11 +184,9 @@ $ Full.InterfaceTypeDefinition mempty "UUID" 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 @@ 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 @@ ] 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 @@ ] 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 view
@@ -1,5 +1,4 @@ {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes #-} module Language.GraphQL.AST.LexerSpec ( spec ) where@@ -7,7 +6,6 @@ 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 @@ 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 @@ 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 view
@@ -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@@ -23,182 +25,154 @@ parse document "" `shouldSucceedOn` "\xfeff{foo}" context "Arguments" $ do- it "accepts block strings as argument" $- parse document "" `shouldSucceedOn` [gql|{- hello(text: """Argument""")- }|]+ it "accepts block strings as argument" $+ parse document "" `shouldSucceedOn`+ "{ hello(text: \"\"\"Argument\"\"\") }" - it "accepts strings as argument" $- parse document "" `shouldSucceedOn` [gql|{- hello(text: "Argument")- }|]+ it "accepts strings as 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 }- }|]+ it "accepts boolean as argument" $+ parse document "" `shouldSucceedOn`+ "{ hello(flag: true) { field1 } }" - it "accepts float as argument" $- parse document "" `shouldSucceedOn` [gql|{- body(height: 172.5) { height }- }|]+ it "accepts float as argument" $+ parse document "" `shouldSucceedOn`+ "{ body(height: 172.5) { height } }" - it "accepts empty list as argument" $- parse document "" `shouldSucceedOn` [gql|{- query(list: []) { field1 }- }|]+ it "accepts empty list as argument" $+ parse document "" `shouldSucceedOn` "{ query(list: []) { field1 } }" - it "accepts two required arguments" $- parse document "" `shouldSucceedOn` [gql|- mutation auth($username: String!, $password: String!){- test- }|]+ it "accepts two required arguments" $+ 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")- }|]+ it "accepts two string arguments" $+ 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""")- }|]- - 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' <> " }")+ it "accepts two block string arguments" $+ 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 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 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- (Description Nothing)- nm- (ArgumentsDefinition [])- (loc :| []))- example1 =- directive "example1"- (DirLoc.TypeSystemDirectiveLocation DirLoc.FieldDefinition)- (Location {line = 1, column = 1})- 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- |]+ let directive name' loc = TypeSystemDefinition+ $ DirectiveDefinition+ (Description Nothing)+ name'+ (ArgumentsDefinition [])+ False+ (loc :| [])+ example1 = directive "example1"+ (DirLoc.TypeSystemDirectiveLocation DirLoc.FieldDefinition)+ (Location {line = 1, column = 1})+ example2 = directive "example2"+ (DirLoc.ExecutableDirectiveLocation DirLoc.Field)+ (Location {line = 2, column = 1})+ 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- $ 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 :| [ ])+ let argumentValue = Just+ $ Node (ConstList [])+ $ 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 +181,42 @@ $ 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 view
@@ -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.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@@ -269,15 +266,15 @@ 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
+ tests/Language/GraphQL/THSpec.hs view
@@ -0,0 +1,24 @@+{- 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\nline3"+ actual = [gql| + line1 + line2 + line3 + |]+ in actual `shouldBe` expected
tests/Language/GraphQL/Validate/RulesSpec.hs view
@@ -3,7 +3,6 @@ obtain one at https://mozilla.org/MPL/2.0/. -} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes #-} module Language.GraphQL.Validate.RulesSpec ( spec@@ -13,8 +12,9 @@ import qualified Data.HashMap.Strict as HashMap import Data.Text (Text) import qualified Language.GraphQL.AST as AST-import Language.GraphQL.TH import Language.GraphQL.Type+import qualified Language.GraphQL.Type.Schema as Schema+import qualified Language.GraphQL.AST.DirectiveLocation as DirectiveLocation import qualified Language.GraphQL.Type.In as In import qualified Language.GraphQL.Type.Out as Out import Language.GraphQL.Validate@@ -22,7 +22,9 @@ import Text.Megaparsec (parse, errorBundlePretty) petSchema :: Schema IO-petSchema = schema queryType Nothing (Just subscriptionType) mempty+petSchema = schema queryType Nothing (Just subscriptionType)+ $ HashMap.singleton "repeat"+ $ Schema.Directive Nothing mempty True [DirectiveLocation.ExecutableDirectiveLocation DirectiveLocation.Field] queryType :: ObjectType IO queryType = ObjectType "Query" Nothing [] $ HashMap.fromList@@ -169,18 +171,16 @@ describe "document" $ do context "executableDefinitionsRule" $ it "rejects type definitions" $- let queryString = [gql|- query getDogName {- dog {- name- color- }- }-- extend type Dog {- color: String- }- |]+ let queryString = "query getDogName {\n\+ \ dog {\n\+ \ name\n\+ \ color\n\+ \ }\n\+ \}\n\+ \\n\+ \extend type Dog {\n\+ \ color: String\n\+ \}" expected = Error { message = "Definition must be OperationDefinition or \@@ -191,15 +191,13 @@ context "singleFieldSubscriptionsRule" $ do it "rejects multiple subscription root fields" $- let queryString = [gql|- subscription sub {- newMessage {- body- sender- }- disallowedSecondRootField- }- |]+ let queryString = "subscription sub {\n\+ \ newMessage {\n\+ \ body\n\+ \ sender\n\+ \ }\n\+ \ disallowedSecondRootField\n\+ \}" expected = Error { message = "Subscription \"sub\" must select only one top \@@ -209,19 +207,17 @@ in validate queryString `shouldContain` [expected] it "rejects multiple subscription root fields coming from a fragment" $- let queryString = [gql|- subscription sub {- ...multipleSubscriptions- }-- fragment multipleSubscriptions on Subscription {- newMessage {- body- sender- }- disallowedSecondRootField- }- |]+ let queryString = "subscription sub {\n\+ \ ...multipleSubscriptions\n\+ \}\n\+ \\n\+ \fragment multipleSubscriptions on Subscription {\n\+ \ newMessage {\n\+ \ body\n\+ \ sender\n\+ \ }\n\+ \ disallowedSecondRootField\n\+ \}" expected = Error { message = "Subscription \"sub\" must select only one top \@@ -231,26 +227,24 @@ in validate queryString `shouldContain` [expected] it "finds corresponding subscription fragment" $- let queryString = [gql|- subscription sub {- ...anotherSubscription- ...multipleSubscriptions- }- fragment multipleSubscriptions on Subscription {- newMessage {- body- }- disallowedSecondRootField {- sender- }- }- fragment anotherSubscription on Subscription {- newMessage {- body- sender- }- }- |]+ let queryString = "subscription sub {\n\+ \ ...anotherSubscription\n\+ \ ...multipleSubscriptions\n\+ \}\n\+ \fragment multipleSubscriptions on Subscription {\n\+ \ newMessage {\n\+ \ body\n\+ \ }\n\+ \ disallowedSecondRootField {\n\+ \ sender\n\+ \ }\n\+ \}\n\+ \fragment anotherSubscription on Subscription {\n\+ \ newMessage {\n\+ \ body\n\+ \ sender\n\+ \ }\n\+ \}" expected = Error { message = "Subscription \"sub\" must select only one top \@@ -261,21 +255,19 @@ context "loneAnonymousOperationRule" $ it "rejects multiple anonymous operations" $- let queryString = [gql|- {- dog {- name- }- }-- query getName {- dog {- owner {- name- }- }- }- |]+ let queryString = "{\n\+ \ dog {\n\+ \ name\n\+ \ }\n\+ \}\n\+ \\n\+ \query getName {\n\+ \ dog {\n\+ \ owner {\n\+ \ name\n\+ \ }\n\+ \ }\n\+ \}" expected = Error { message = "This anonymous operation must be the only defined \@@ -286,19 +278,17 @@ context "uniqueOperationNamesRule" $ it "rejects operations with the same name" $- let queryString = [gql|- query dogOperation {- dog {- name- }- }-- mutation dogOperation {- mutateDog {- id- }- }- |]+ let queryString = "query dogOperation {\n\+ \ dog {\n\+ \ name\n\+ \ }\n\+ \}\n\+ \\n\+ \mutation dogOperation {\n\+ \ mutateDog {\n\+ \ id\n\+ \ }\n\+ \}" expected = Error { message = "There can be only one operation named \@@ -309,23 +299,21 @@ context "uniqueFragmentNamesRule" $ it "rejects fragments with the same name" $- let queryString = [gql|- {- dog {- ...fragmentOne- }- }-- fragment fragmentOne on Dog {- name- }-- fragment fragmentOne on Dog {- owner {- name- }- }- |]+ let queryString = "{\n\+ \ dog {\n\+ \ ...fragmentOne\n\+ \ }\n\+ \}\n\+ \\n\+ \fragment fragmentOne on Dog {\n\+ \ name\n\+ \}\n\+ \\n\+ \fragment fragmentOne on Dog {\n\+ \ owner {\n\+ \ name\n\+ \ }\n\+ \}" expected = Error { message = "There can be only one fragment named \@@ -336,13 +324,11 @@ context "fragmentSpreadTargetDefinedRule" $ it "rejects the fragment spread without a target" $- let queryString = [gql|- {- dog {- ...undefinedFragment- }- }- |]+ let queryString = "{\n\+ \ dog {\n\+ \ ...undefinedFragment\n\+ \ }\n\+ \}" expected = Error { message = "Fragment target \"undefinedFragment\" is \@@ -353,16 +339,14 @@ context "fragmentSpreadTypeExistenceRule" $ do it "rejects fragment spreads without an unknown target type" $- let queryString = [gql|- {- dog {- ...notOnExistingType- }- }- fragment notOnExistingType on NotInSchema {- name- }- |]+ let queryString = "{\n\+ \ dog {\n\+ \ ...notOnExistingType\n\+ \ }\n\+ \}\n\+ \fragment notOnExistingType on NotInSchema {\n\+ \ name\n\+ \}" expected = Error { message = "Fragment \"notOnExistingType\" is specified on \@@ -373,13 +357,11 @@ in validate queryString `shouldBe` [expected] it "rejects inline fragments without a target" $- let queryString = [gql|- {- ... on NotInSchema {- name- }- }- |]+ let queryString = "{\n\+ \ ... on NotInSchema {\n\+ \ name\n\+ \ }\n\+ \}" expected = Error { message = "Inline fragment is specified on type \@@ -390,16 +372,14 @@ context "fragmentsOnCompositeTypesRule" $ do it "rejects fragments on scalar types" $- let queryString = [gql|- {- dog {- ...fragOnScalar- }- }- fragment fragOnScalar on Int {- name- }- |]+ let queryString = "{\n\+ \ dog {\n\+ \ ...fragOnScalar\n\+ \ }\n\+ \}\n\+ \fragment fragOnScalar on Int {\n\+ \ name\n\+ \}" expected = Error { message = "Fragment cannot condition on non composite type \@@ -409,13 +389,11 @@ in validate queryString `shouldContain` [expected] it "rejects inline fragments on scalar types" $- let queryString = [gql|- {- ... on Boolean {- name- }- }- |]+ let queryString = "{\n\+ \ ... on Boolean {\n\+ \ name\n\+ \ }\n\+ \}" expected = Error { message = "Fragment cannot condition on non composite type \@@ -426,17 +404,15 @@ context "noUnusedFragmentsRule" $ it "rejects unused fragments" $- let queryString = [gql|- fragment nameFragment on Dog { # unused- name- }-- {- dog {- name- }- }- |]+ let queryString = "fragment nameFragment on Dog { # unused\n\+ \ name\n\+ \}\n\+ \\n\+ \{\n\+ \ dog {\n\+ \ name\n\+ \ }\n\+ \}" expected = Error { message = "Fragment \"nameFragment\" is never used."@@ -446,21 +422,19 @@ context "noFragmentCyclesRule" $ it "rejects spreads that form cycles" $- let queryString = [gql|- {- dog {- ...nameFragment- }- }- fragment nameFragment on Dog {- name- ...barkVolumeFragment- }- fragment barkVolumeFragment on Dog {- barkVolume- ...nameFragment- }- |]+ let queryString = "{\n\+ \ dog {\n\+ \ ...nameFragment\n\+ \ }\n\+ \}\n\+ \fragment nameFragment on Dog {\n\+ \ name\n\+ \ ...barkVolumeFragment\n\+ \}\n\+ \fragment barkVolumeFragment on Dog {\n\+ \ barkVolume\n\+ \ ...nameFragment\n\+ \}" error1 = Error { message = "Cannot spread fragment \"barkVolumeFragment\" \@@ -479,13 +453,11 @@ context "uniqueArgumentNamesRule" $ it "rejects duplicate field arguments" $- let queryString = [gql|- {- dog {- isHousetrained(atOtherHomes: true, atOtherHomes: true)- }- }- |]+ let queryString = "{\n\+ \ dog {\n\+ \ isHousetrained(atOtherHomes: true, atOtherHomes: true)\n\+ \ }\n\+ \}" expected = Error { message = "There can be only one argument named \@@ -494,15 +466,13 @@ } in validate queryString `shouldBe` [expected] - context "uniqueDirectiveNamesRule" $+ context "uniqueDirectiveNamesRule" $ do it "rejects more than one directive per location" $- let queryString = [gql|- query ($foo: Boolean = true, $bar: Boolean = false) {- dog @skip(if: $foo) @skip(if: $bar) {- name- }- }- |]+ let queryString = "query ($foo: Boolean = true, $bar: Boolean = false) {\n\+ \ dog @skip(if: $foo) @skip(if: $bar) {\n\+ \ name\n\+ \ }\n\+ \}" expected = Error { message = "There can be only one directive named \"skip\"."@@ -510,15 +480,21 @@ } in validate queryString `shouldBe` [expected] + it "allows repeating repeatable directives" $+ let queryString = "query {\n\+ \ dog @repeat @repeat {\n\+ \ name\n\+ \ }\n\+ \}"+ in validate queryString `shouldBe` []+ context "uniqueVariableNamesRule" $ it "rejects duplicate variables" $- let queryString = [gql|- query houseTrainedQuery($atOtherHomes: Boolean, $atOtherHomes: Boolean) {- dog {- isHousetrained(atOtherHomes: $atOtherHomes)- }- }- |]+ let queryString = "query houseTrainedQuery($atOtherHomes: Boolean, $atOtherHomes: Boolean) {\n\+ \ dog {\n\+ \ isHousetrained(atOtherHomes: $atOtherHomes)\n\+ \ }\n\+ \}" expected = Error { message = "There can be only one variable named \@@ -529,13 +505,11 @@ context "variablesAreInputTypesRule" $ it "rejects non-input types as variables" $- let queryString = [gql|- query takesDogBang($dog: Dog!) {- dog {- isHousetrained(atOtherHomes: $dog)- }- }- |]+ let queryString = "query takesDogBang($dog: Dog!) {\n\+ \ dog {\n\+ \ isHousetrained(atOtherHomes: $dog)\n\+ \ }\n\+ \}" expected = Error { message = "Variable \"$dog\" cannot be non-input type \@@ -546,17 +520,15 @@ context "noUndefinedVariablesRule" $ do it "rejects undefined variables" $- let queryString = [gql|- query variableIsNotDefinedUsedInSingleFragment {- dog {- ...isHousetrainedFragment- }- }-- fragment isHousetrainedFragment on Dog {- isHousetrained(atOtherHomes: $atOtherHomes)- }- |]+ let queryString = "query variableIsNotDefinedUsedInSingleFragment {\n\+ \ dog {\n\+ \ ...isHousetrainedFragment\n\+ \ }\n\+ \}\n\+ \\n\+ \fragment isHousetrainedFragment on Dog {\n\+ \ isHousetrained(atOtherHomes: $atOtherHomes)\n\+ \}" expected = Error { message = "Variable \"$atOtherHomes\" is not defined by \@@ -567,13 +539,11 @@ in validate queryString `shouldBe` [expected] it "gets variable location inside an input object" $- let queryString = [gql|- query {- findDog (complex: { name: $name }) {- name- }- }- |]+ let queryString = "query {\n\+ \ findDog (complex: { name: $name }) {\n\+ \ name\n\+ \ }\n\+ \}" expected = Error { message = "Variable \"$name\" is not defined." , locations = [AST.Location 2 29]@@ -581,13 +551,11 @@ in validate queryString `shouldBe` [expected] it "gets variable location inside an array" $- let queryString = [gql|- query {- findCats (commands: [JUMP, $command]) {- name- }- }- |]+ let queryString = "query {\n\+ \ findCats (commands: [JUMP, $command]) {\n\+ \ name\n\+ \ }\n\+ \}" expected = Error { message = "Variable \"$command\" is not defined." , locations = [AST.Location 2 30]@@ -596,13 +564,11 @@ context "noUnusedVariablesRule" $ do it "rejects unused variables" $- let queryString = [gql|- query variableUnused($atOtherHomes: Boolean) {- dog {- isHousetrained- }- }- |]+ let queryString = "query variableUnused($atOtherHomes: Boolean) {\n\+ \ dog {\n\+ \ isHousetrained\n\+ \ }\n\+ \}" expected = Error { message = "Variable \"$atOtherHomes\" is never used in \@@ -612,24 +578,20 @@ in validate queryString `shouldBe` [expected] it "detects variables in properties of input objects" $- let queryString = [gql|- query withVar ($name: String!) {- findDog (complex: { name: $name }) {- name- }- }- |]+ let queryString = "query withVar ($name: String!) {\n\+ \ findDog (complex: { name: $name }) {\n\+ \ name\n\+ \ }\n\+ \}" in validate queryString `shouldBe` [] context "uniqueInputFieldNamesRule" $ it "rejects duplicate fields in input objects" $- let queryString = [gql|- {- findDog(complex: { name: "Fido", name: "Jack" }) {- name- }- }- |]+ let queryString = "{\n\+ \ findDog(complex: { name: \"Fido\", name: \"Jack\" }) {\n\+ \ name\n\+ \ }\n\+ \}" expected = Error { message = "There can be only one input field named \"name\"."@@ -639,13 +601,11 @@ context "fieldsOnCorrectTypeRule" $ it "rejects undefined fields" $- let queryString = [gql|- {- dog {- meowVolume- }- }- |]+ let queryString = "{\n\+ \ dog {\n\+ \ meowVolume\n\+ \ }\n\+ \}" expected = Error { message = "Cannot query field \"meowVolume\" on type \"Dog\"."@@ -655,15 +615,13 @@ context "scalarLeafsRule" $ it "rejects scalar fields with not empty selection set" $- let queryString = [gql|- {- dog {- barkVolume {- sinceWhen- }- }- }- |]+ let queryString = "{\n\+ \ dog {\n\+ \ barkVolume {\n\+ \ sinceWhen\n\+ \ }\n\+ \ }\n\+ \}" expected = Error { message = "Field \"barkVolume\" must not have a selection \@@ -674,13 +632,11 @@ context "knownArgumentNamesRule" $ do it "rejects field arguments missing in the type" $- let queryString = [gql|- {- dog {- doesKnowCommand(command: CLEAN_UP_HOUSE, dogCommand: SIT)- }- }- |]+ let queryString = "{\n\+ \ dog {\n\+ \ doesKnowCommand(command: CLEAN_UP_HOUSE, dogCommand: SIT)\n\+ \ }\n\+ \}" expected = Error { message = "Unknown argument \"command\" on field \@@ -690,13 +646,11 @@ in validate queryString `shouldBe` [expected] it "rejects directive arguments missing in the definition" $- let queryString = [gql|- {- dog {- isHousetrained(atOtherHomes: true) @include(unless: false, if: true)- }- }- |]+ let queryString = "{\n\+ \ dog {\n\+ \ isHousetrained(atOtherHomes: true) @include(unless: false, if: true)\n\+ \ }\n\+ \}" expected = Error { message = "Unknown argument \"unless\" on directive \@@ -707,13 +661,11 @@ context "knownDirectiveNamesRule" $ it "rejects undefined directives" $- let queryString = [gql|- {- dog {- isHousetrained(atOtherHomes: true) @ignore(if: true)- }- }- |]+ let queryString = "{\n\+ \ dog {\n\+ \ isHousetrained(atOtherHomes: true) @ignore(if: true)\n\+ \ }\n\+ \}" expected = Error { message = "Unknown directive \"@ignore\"." , locations = [AST.Location 3 40]@@ -722,13 +674,11 @@ context "knownInputFieldNamesRule" $ it "rejects undefined input object fields" $- let queryString = [gql|- {- findDog(complex: { favoriteCookieFlavor: "Bacon", name: "Jack" }) {- name- }- }- |]+ let queryString = "{\n\+ \ findDog(complex: { favoriteCookieFlavor: \"Bacon\", name: \"Jack\" }) {\n\+ \ name\n\+ \ }\n\+ \}" expected = Error { message = "Field \"favoriteCookieFlavor\" is not defined \@@ -739,13 +689,11 @@ context "directivesInValidLocationsRule" $ it "rejects directives in invalid locations" $- let queryString = [gql|- query @skip(if: $foo) {- dog {- name- }- }- |]+ let queryString = "query @skip(if: $foo) {\n\+ \ dog {\n\+ \ name\n\+ \ }\n\+ \}" expected = Error { message = "Directive \"@skip\" may not be used on QUERY."@@ -755,14 +703,12 @@ context "overlappingFieldsCanBeMergedRule" $ do it "fails to merge fields of mismatching types" $- let queryString = [gql|- {- dog {- name: nickname- name- }- }- |]+ let queryString = "{\n\+ \ dog {\n\+ \ name: nickname\n\+ \ name\n\+ \ }\n\+ \}" expected = Error { message = "Fields \"name\" conflict because \"nickname\" and \@@ -774,14 +720,12 @@ in validate queryString `shouldBe` [expected] it "fails if the arguments of the same field don't match" $- let queryString = [gql|- {- dog {- doesKnowCommand(dogCommand: SIT)- doesKnowCommand(dogCommand: HEEL)- }- }- |]+ let queryString = "{\n\+ \ dog {\n\+ \ doesKnowCommand(dogCommand: SIT)\n\+ \ doesKnowCommand(dogCommand: HEEL)\n\+ \ }\n\+ \}" expected = Error { message = "Fields \"doesKnowCommand\" conflict because they \@@ -793,14 +737,12 @@ in validate queryString `shouldBe` [expected] it "fails to merge same-named field and alias" $- let queryString = [gql|- {- dog {- doesKnowCommand(dogCommand: SIT)- doesKnowCommand: isHousetrained(atOtherHomes: true)- }- }- |]+ let queryString = "{\n\+ \ dog {\n\+ \ doesKnowCommand(dogCommand: SIT)\n\+ \ doesKnowCommand: isHousetrained(atOtherHomes: true)\n\+ \ }\n\+ \}" expected = Error { message = "Fields \"doesKnowCommand\" conflict because \@@ -812,18 +754,16 @@ in validate queryString `shouldBe` [expected] it "looks for fields after a successfully merged field pair" $- let queryString = [gql|- {- dog {- name- doesKnowCommand(dogCommand: SIT)- }- dog {- name- doesKnowCommand: isHousetrained(atOtherHomes: true)- }- }- |]+ let queryString = "{\n\+ \ dog {\n\+ \ name\n\+ \ doesKnowCommand(dogCommand: SIT)\n\+ \ }\n\+ \ dog {\n\+ \ name\n\+ \ doesKnowCommand: isHousetrained(atOtherHomes: true)\n\+ \ }\n\+ \}" expected = Error { message = "Fields \"doesKnowCommand\" conflict because \@@ -836,15 +776,13 @@ context "possibleFragmentSpreadsRule" $ do it "rejects object inline spreads outside object scope" $- let queryString = [gql|- {- dog {- ... on Cat {- meowVolume- }- }- }- |]+ let queryString = "{\n\+ \ dog {\n\+ \ ... on Cat {\n\+ \ meowVolume\n\+ \ }\n\+ \ }\n\+ \}" expected = Error { message = "Fragment cannot be spread here as objects of type \@@ -854,17 +792,15 @@ in validate queryString `shouldBe` [expected] it "rejects object named spreads outside object scope" $- let queryString = [gql|- {- dog {- ... catInDogFragmentInvalid- }- }-- fragment catInDogFragmentInvalid on Cat {- meowVolume- }- |]+ let queryString = "{\n\+ \ dog {\n\+ \ ... catInDogFragmentInvalid\n\+ \ }\n\+ \}\n\+ \\n\+ \fragment catInDogFragmentInvalid on Cat {\n\+ \ meowVolume\n\+ \}" expected = Error { message = "Fragment \"catInDogFragmentInvalid\" cannot be \@@ -876,13 +812,11 @@ context "providedRequiredInputFieldsRule" $ it "rejects missing required input fields" $- let queryString = [gql|- {- findDog(complex: { name: null }) {- name- }- }- |]+ let queryString = "{\n\+ \ findDog(complex: { name: null }) {\n\+ \ name\n\+ \ }\n\+ \}" expected = Error { message = "Input field \"name\" of type \"DogData\" is \@@ -893,13 +827,11 @@ context "providedRequiredArgumentsRule" $ do it "checks for (non-)nullable arguments" $- let queryString = [gql|- {- dog {- doesKnowCommand(dogCommand: null)- }- }- |]+ let queryString = "{\n\+ \ dog {\n\+ \ doesKnowCommand(dogCommand: null)\n\+ \ }\n\+ \}" expected = Error { message = "Field \"doesKnowCommand\" argument \"dogCommand\" \@@ -911,13 +843,11 @@ context "variablesInAllowedPositionRule" $ do it "rejects wrongly typed variable arguments" $- let queryString = [gql|- query dogCommandArgQuery($dogCommandArg: DogCommand) {- dog {- doesKnowCommand(dogCommand: $dogCommandArg)- }- }- |]+ let queryString = "query dogCommandArgQuery($dogCommandArg: DogCommand) {\n\+ \ dog {\n\+ \ doesKnowCommand(dogCommand: $dogCommandArg)\n\+ \ }\n\+ \}" expected = Error { message = "Variable \"$dogCommandArg\" of type \@@ -928,13 +858,11 @@ in validate queryString `shouldBe` [expected] it "rejects wrongly typed variable arguments" $- let queryString = [gql|- query intCannotGoIntoBoolean($intArg: Int) {- dog {- isHousetrained(atOtherHomes: $intArg)- }- }- |]+ let queryString = "query intCannotGoIntoBoolean($intArg: Int) {\n\+ \ dog {\n\+ \ isHousetrained(atOtherHomes: $intArg)\n\+ \ }\n\+ \}" expected = Error { message = "Variable \"$intArg\" of type \"Int\" used in \@@ -945,13 +873,11 @@ context "valuesOfCorrectTypeRule" $ do it "rejects values of incorrect types" $- let queryString = [gql|- {- dog {- isHousetrained(atOtherHomes: 3)- }- }- |]+ let queryString = "{\n\+ \ dog {\n\+ \ isHousetrained(atOtherHomes: 3)\n\+ \ }\n\+ \}" expected = Error { message = "Value 3 cannot be coerced to type \"Boolean\"."@@ -960,13 +886,11 @@ in validate queryString `shouldBe` [expected] it "uses the location of a single list value" $- let queryString = [gql|- {- cat {- doesKnowCommands(catCommands: [3])- }- }- |]+ let queryString = "{\n\+ \ cat {\n\+ \ doesKnowCommands(catCommands: [3])\n\+ \ }\n\+ \}" expected = Error { message = "Value 3 cannot be coerced to type \"CatCommand!\"."@@ -975,13 +899,11 @@ in validate queryString `shouldBe` [expected] it "validates input object properties once" $- let queryString = [gql|- {- findDog(complex: { name: 3 }) {- name- }- }- |]+ let queryString = "{\n\+ \ findDog(complex: { name: 3 }) {\n\+ \ name\n\+ \ }\n\+ \}" expected = Error { message = "Value 3 cannot be coerced to type \"String!\"."@@ -990,13 +912,11 @@ in validate queryString `shouldBe` [expected] it "checks for required list members" $- let queryString = [gql|- {- cat {- doesKnowCommands(catCommands: [null])- }- }- |]+ let queryString = "{\n\+ \ cat {\n\+ \ doesKnowCommands(catCommands: [null])\n\+ \ }\n\+ \}" expected = Error { message = "List of non-null values of type \"CatCommand\" \