diff options
24 files changed, 850 insertions, 892 deletions
diff --git a/.gitea/deploy.awk b/.gitea/deploy.awk new file mode 100644 index 0000000..ed542f0 --- /dev/null +++ b/.gitea/deploy.awk @@ -0,0 +1,3 @@ +END { + system("cabal upload --username belka --password "ENVIRON["HACKAGE_PASSWORD"]" "$0) +} diff --git a/.gitea/workflows/build.yml b/.gitea/workflows/build.yml index 3cb0475..ebb81c3 100644 --- a/.gitea/workflows/build.yml +++ b/.gitea/workflows/build.yml @@ -9,28 +9,14 @@ on: jobs: audit: - runs-on: haskell + runs-on: buildenv steps: - - name: Set up environment - run: | - apt-get update -y - apt-get upgrade -y - apt-get install -y nodejs pkg-config - uses: actions/checkout@v4 - - name: Install dependencies - run: | - cabal update - cabal install hlint "--constraint=hlint ==3.8" - - run: cabal exec hlint -- src tests + - run: hlint -- src tests test: - runs-on: haskell + runs-on: buildenv steps: - - name: Set up environment - run: | - apt-get update -y - apt-get upgrade -y - apt-get install -y nodejs pkg-config - uses: actions/checkout@v4 - name: Install dependencies run: cabal update @@ -39,13 +25,8 @@ jobs: - run: cabal test --test-show-details=streaming doc: - runs-on: haskell + runs-on: buildenv steps: - - name: Set up environment - run: | - apt-get update -y - apt-get upgrade -y - apt-get install -y nodejs pkg-config - uses: actions/checkout@v4 - name: Install dependencies run: cabal update diff --git a/.gitea/workflows/release.yml b/.gitea/workflows/release.yml index b815625..08e90c2 100644 --- a/.gitea/workflows/release.yml +++ b/.gitea/workflows/release.yml @@ -7,17 +7,11 @@ on: jobs: release: - runs-on: haskell + runs-on: buildenv steps: - - name: Set up environment - run: | - apt-get update -y - apt-get upgrade -y - apt-get install -y nodejs pkg-config - uses: actions/checkout@v4 - name: Upload a candidate env: HACKAGE_PASSWORD: ${{ secrets.HACKAGE_PASSWORD }} run: | - cabal sdist - cabal upload --username belka --password ${HACKAGE_PASSWORD} + cabal sdist | awk -f .gitea/deploy.awk diff --git a/CHANGELOG.md b/CHANGELOG.md index 884d590..3dda90c 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -6,6 +6,20 @@ The format is based on 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 @@ and this project adheres to ### 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 diff --git a/graphql.cabal b/graphql.cabal index 225ff29..3ee6561 100644 --- a/graphql.cabal +++ b/graphql.cabal @@ -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 @@ extra-source-files: 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 @@ library 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 @@ 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 diff --git a/src/Language/GraphQL/AST/DirectiveLocation.hs b/src/Language/GraphQL/AST/DirectiveLocation.hs index d109666..600f931 100644 --- a/src/Language/GraphQL/AST/DirectiveLocation.hs +++ b/src/Language/GraphQL/AST/DirectiveLocation.hs @@ -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(..) diff --git a/src/Language/GraphQL/AST/Document.hs b/src/Language/GraphQL/AST/Document.hs index 66fc246..101cf78 100644 --- a/src/Language/GraphQL/AST/Document.hs +++ b/src/Language/GraphQL/AST/Document.hs @@ -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 diff --git a/src/Language/GraphQL/AST/Encoder.hs b/src/Language/GraphQL/AST/Encoder.hs index 120fb64..a1076e4 100644 --- a/src/Language/GraphQL/AST/Encoder.hs +++ b/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) @@ -276,7 +277,7 @@ pipeList :: Foldable t => Formatter -> t Lazy.Text -> Lazy.Text 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 = diff --git a/src/Language/GraphQL/AST/Lexer.hs b/src/Language/GraphQL/AST/Lexer.hs index ab1f36f..62cf4d2 100644 --- a/src/Language/GraphQL/AST/Lexer.hs +++ b/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,22 +38,22 @@ import qualified Data.List.NonEmpty as NonEmpty 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 :: 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,10 +182,10 @@ name :: Parser T.Text name = do firstLetter <- nameFirstLetter rest <- many $ nameFirstLetter <|> digitChar - _ <- spaceConsumer - return $ TL.toStrict $ TL.cons firstLetter $ TL.pack rest - where - nameFirstLetter = satisfy isAsciiUpper <|> satisfy isAsciiLower <|> char '_' + 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 @@ 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 - . 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 diff --git a/src/Language/GraphQL/AST/Parser.hs b/src/Language/GraphQL/AST/Parser.hs index e19823c..f325ee7 100644 --- a/src/Language/GraphQL/AST/Parser.hs +++ b/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" diff --git a/src/Language/GraphQL/Execute/Coerce.hs b/src/Language/GraphQL/Execute/Coerce.hs index 54fc1c1..f67d74b 100644 --- a/src/Language/GraphQL/Execute/Coerce.hs +++ b/src/Language/GraphQL/Execute/Coerce.hs @@ -147,7 +147,7 @@ coerceInputLiteral (In.EnumBaseType type') (Type.Enum enumValue) | member enumValue type' = Just $ Type.Enum enumValue where member value (Type.EnumType _ _ members) = HashMap.member value members -coerceInputLiteral (In.InputObjectBaseType type') (Type.Object values) = +coerceInputLiteral (In.InputObjectBaseType type') (Type.Object values) = let (In.InputObjectType _ _ inputFields) = type' in Type.Object <$> HashMap.foldrWithKey (matchFieldValues' values) (Just HashMap.empty) inputFields diff --git a/src/Language/GraphQL/TH.hs b/src/Language/GraphQL/TH.hs index 8e1fcb3..22ffdd0 100644 --- a/src/Language/GraphQL/TH.hs +++ b/src/Language/GraphQL/TH.hs @@ -12,20 +12,30 @@ import Language.Haskell.TH (Exp(..), Lit(..)) 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 diff --git a/src/Language/GraphQL/Type/In.hs b/src/Language/GraphQL/Type/In.hs index c777e69..bd78c8c 100644 --- a/src/Language/GraphQL/Type/In.hs +++ b/src/Language/GraphQL/Type/In.hs @@ -74,6 +74,7 @@ instance Show Type where -- | Field argument definition. data Argument = Argument (Maybe Text) Type (Maybe Definition.Value) + deriving Eq -- | Field argument definitions. type Arguments = HashMap Name Argument diff --git a/src/Language/GraphQL/Type/Internal.hs b/src/Language/GraphQL/Type/Internal.hs index ce3b121..a126782 100644 --- a/src/Language/GraphQL/Type/Internal.hs +++ b/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 diff --git a/src/Language/GraphQL/Type/Schema.hs b/src/Language/GraphQL/Type/Schema.hs index c8ac77a..6084a77 100644 --- a/src/Language/GraphQL/Type/Schema.hs +++ b/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 diff --git a/src/Language/GraphQL/Validate.hs b/src/Language/GraphQL/Validate.hs index f929b98..5feb85a 100644 --- a/src/Language/GraphQL/Validate.hs +++ b/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 @@ -283,7 +283,7 @@ operationDefinition rule context operation 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 @@ arguments :: forall m -> 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 @@ 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 diff --git a/src/Language/GraphQL/Validate/Rules.hs b/src/Language/GraphQL/Validate/Rules.hs index 2d7adba..3fef94d 100644 --- a/src/Language/GraphQL/Validate/Rules.hs +++ b/src/Language/GraphQL/Validate/Rules.hs @@ -50,14 +50,15 @@ 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 @@ -253,14 +254,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' } @@ -530,16 +533,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" - 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 :: 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 " @@ -833,7 +840,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 @@ -854,18 +861,18 @@ knownArgumentNamesRule = ArgumentsRule fieldRule directiveRule 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 @@ 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] @@ -943,7 +950,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 @@ -1411,7 +1418,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 diff --git a/tests/Language/GraphQL/AST/Arbitrary.hs b/tests/Language/GraphQL/AST/Arbitrary.hs index 4f74bf3..69247b1 100644 --- a/tests/Language/GraphQL/AST/Arbitrary.hs +++ b/tests/Language/GraphQL/AST/Arbitrary.hs @@ -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 @@ num = ['0'..'9'] 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 @@ 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 @@ -60,8 +85,9 @@ 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 @@ -88,8 +114,9 @@ instance Arbitrary AnyValue , 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 @@ 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' diff --git a/tests/Language/GraphQL/AST/EncoderSpec.hs b/tests/Language/GraphQL/AST/EncoderSpec.hs index 3fa6a02..e98d5ef 100644 --- a/tests/Language/GraphQL/AST/EncoderSpec.hs +++ b/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 - [ 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 @@ 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 @@ -210,11 +184,9 @@ spec = do $ 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 @@ 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 diff --git a/tests/Language/GraphQL/AST/LexerSpec.hs b/tests/Language/GraphQL/AST/LexerSpec.hs index e22c6b0..3cfa22e 100644 --- a/tests/Language/GraphQL/AST/LexerSpec.hs +++ b/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" $ diff --git a/tests/Language/GraphQL/AST/ParserSpec.hs b/tests/Language/GraphQL/AST/ParserSpec.hs index 13faa21..3bd2576 100644 --- a/tests/Language/GraphQL/AST/ParserSpec.hs +++ b/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 @@ -23,182 +25,154 @@ spec = describe "Parser" $ do parse document "" `shouldSucceedOn` "\xfeff{foo}" context "Arguments" $ do - it "accepts block strings as argument" $ - parse document "" `shouldSucceedOn` [gql|{ - hello(text: """Argument""") - }|] - - it "accepts strings as argument" $ - parse document "" `shouldSucceedOn` [gql|{ - hello(text: "Argument") - }|] - - it "accepts int as argument1" $ - parse document "" `shouldSucceedOn` [gql|{ - user(id: 4) - }|] - - it "accepts boolean as argument" $ - parse document "" `shouldSucceedOn` [gql|{ - hello(flag: true) { field1 } - }|] - - it "accepts float as argument" $ - parse document "" `shouldSucceedOn` [gql|{ - body(height: 172.5) { height } - }|] - - it "accepts empty list as argument" $ - parse document "" `shouldSucceedOn` [gql|{ - query(list: []) { field1 } - }|] - - it "accepts two required arguments" $ - parse document "" `shouldSucceedOn` [gql| - 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 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 block strings as argument" $ + parse document "" `shouldSucceedOn` + "{ hello(text: \"\"\"Argument\"\"\") }" + + it "accepts strings as argument" $ + parse document "" `shouldSucceedOn` "{ hello(text: \"Argument\") }" + + it "accepts int as argument" $ + parse document "" `shouldSucceedOn` "{ user(id: 4) }" + + it "accepts boolean as argument" $ + parse document "" `shouldSucceedOn` + "{ hello(flag: true) { field1 } }" + + it "accepts float as argument" $ + parse document "" `shouldSucceedOn` + "{ body(height: 172.5) { height } }" + + it "accepts empty list as argument" $ + parse document "" `shouldSucceedOn` "{ query(list: []) { field1 } }" + + it "accepts two required arguments" $ + parse document "" `shouldSucceedOn` + "mutation auth($username: String!, $password: String!) { test }" + + it "accepts two string arguments" $ + parse document "" `shouldSucceedOn` + "mutation auth { test(username: \"username\", password: \"password\") }" + + 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 @@ 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\ + \}" diff --git a/tests/Language/GraphQL/ExecuteSpec.hs b/tests/Language/GraphQL/ExecuteSpec.hs index 52bd410..953f739 100644 --- a/tests/Language/GraphQL/ExecuteSpec.hs +++ b/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 @@ -269,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 diff --git a/tests/Language/GraphQL/THSpec.hs b/tests/Language/GraphQL/THSpec.hs new file mode 100644 index 0000000..2858ab2 --- /dev/null +++ b/tests/Language/GraphQL/THSpec.hs @@ -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 diff --git a/tests/Language/GraphQL/Validate/RulesSpec.hs b/tests/Language/GraphQL/Validate/RulesSpec.hs index 7bdbd86..c48b329 100644 --- a/tests/Language/GraphQL/Validate/RulesSpec.hs +++ b/tests/Language/GraphQL/Validate/RulesSpec.hs @@ -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 Data.Foldable (toList) 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 Test.Hspec (Spec, context, describe, it, shouldBe, shouldContain) 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 @@ spec = 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 @@ spec = 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 @@ spec = 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 @@ spec = 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 @@ spec = 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 @@ spec = 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 @@ spec = 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 @@ spec = 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 @@ spec = 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 @@ spec = 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 @@ spec = 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 @@ spec = 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 @@ spec = 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 @@ spec = 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 @@ spec = 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 @@ spec = } 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 @@ spec = } 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 @@ spec = 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 @@ spec = 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 @@ spec = 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 @@ spec = 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 @@ spec = 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 @@ spec = 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 @@ spec = 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 @@ spec = 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 @@ spec = 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 @@ spec = 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 @@ spec = 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 @@ spec = 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 @@ spec = 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 @@ spec = 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 @@ spec = 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 @@ spec = 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 @@ spec = 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 @@ spec = 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 @@ spec = 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 @@ spec = 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 @@ spec = 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 @@ spec = 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 @@ spec = 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 @@ spec = 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 @@ spec = 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 @@ spec = 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 @@ spec = 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\" \ |