aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--CHANGELOG.md16
-rw-r--r--graphql.cabal25
-rw-r--r--src/Language/GraphQL.hs101
-rw-r--r--src/Language/GraphQL/AST/Document.hs8
-rw-r--r--src/Language/GraphQL/AST/Encoder.hs279
-rw-r--r--src/Language/GraphQL/Execute.hs11
-rw-r--r--src/Language/GraphQL/Execute/Coerce.hs76
-rw-r--r--src/Test/Hspec/GraphQL.hs49
-rw-r--r--tests/Language/GraphQL/AST/DocumentSpec.hs6
-rw-r--r--tests/Language/GraphQL/AST/EncoderSpec.hs89
-rw-r--r--tests/Language/GraphQL/ExecuteSpec.hs28
11 files changed, 416 insertions, 272 deletions
diff --git a/CHANGELOG.md b/CHANGELOG.md
index 0ce7624..d929322 100644
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -6,6 +6,21 @@ The format is based on
and this project adheres to
[Haskell Package Versioning Policy](https://pvp.haskell.org/).
+## [1.2.0.0] - 2023-02-28
+### Added
+- Schema printing.
+- `Semigroup` and `Monoid` instances for `AST.Document.Description`.
+- Support for vector 0.13.0.0 and transformers 0.6.1.0.
+
+### Fixed
+- Fix resolvers returning a list in the reverse order.
+
+### Removed
+- GHC 8 support.
+- Cabal -json flag.
+- `Test.Hspec.GraphQL`: moved to `graphql-spice` package.
+- CPP `ifdef WITH_JSON` blocks.
+
## [1.1.0.0] - 2022-12-24
### Changed
- Removed deprecated `Language.GraphQL.Error` functions: `addErr`, `addErrMsg`,
@@ -490,6 +505,7 @@ and this project adheres to
### Added
- Data types for the GraphQL language.
+[1.2.0.0]: https://www.caraus.tech/projects/pub-graphql/repository/23/diff?rev=v1.2.0.0&rev_to=v1.1.0.0
[1.1.0.0]: https://www.caraus.tech/projects/pub-graphql/repository/23/diff?rev=v1.1.0.0&rev_to=v1.0.3.0
[1.0.3.0]: https://www.caraus.tech/projects/pub-graphql/repository/23/diff?rev=v1.0.3.0&rev_to=v1.0.2.0
[1.0.2.0]: https://www.caraus.tech/projects/pub-graphql/repository/23/diff?rev=v1.0.2.0&rev_to=v1.0.1.0
diff --git a/graphql.cabal b/graphql.cabal
index c448f0e..644d227 100644
--- a/graphql.cabal
+++ b/graphql.cabal
@@ -1,7 +1,7 @@
cabal-version: 2.4
name: graphql
-version: 1.1.0.0
+version: 1.2.0.0
synopsis: Haskell GraphQL implementation
description: Haskell <https://spec.graphql.org/June2018/ GraphQL> implementation.
category: Language
@@ -11,7 +11,7 @@ author: Danny Navarro <j@dannynavarro.net>,
Matthías Páll Gissurarson <mpg@mpg.is>,
Sólrún Halla Einarsdóttir <she@mpg.is>
maintainer: belka@caraus.de
-copyright: (c) 2019-2022 Eugen Wissner,
+copyright: (c) 2019-2023 Eugen Wissner,
(c) 2015-2017 J. Daniel Navarro
license: MPL-2.0 AND BSD-3-Clause
license-files: LICENSE,
@@ -21,18 +21,12 @@ extra-source-files:
CHANGELOG.md
README.md
tested-with:
- GHC == 8.10.7,
- GHC == 9.2.4
+ GHC == 9.2.5
source-repository head
type: git
location: git://caraus.tech/pub/graphql.git
-flag Json
- description: Whether to build against @aeson 1.x@
- default: False
- manual: True
-
library
exposed-modules:
Language.GraphQL
@@ -53,7 +47,6 @@ library
Language.GraphQL.Type.Schema
Language.GraphQL.Validate
Language.GraphQL.Validate.Validation
- Test.Hspec.GraphQL
other-modules:
Language.GraphQL.Execute.Transform
Language.GraphQL.Type.Definition
@@ -72,15 +65,9 @@ library
parser-combinators >= 1.3 && < 2,
template-haskell >= 2.16 && < 3,
text >= 1.2 && < 3,
- transformers ^>= 0.5.6,
+ transformers >= 0.5.6 && < 0.7,
unordered-containers ^>= 0.2.14,
- vector ^>= 0.12.3
- if flag(Json)
- build-depends:
- aeson >= 1.5.6 && < 1.6,
- hspec-expectations >= 0.8.2 && < 0.9,
- scientific >= 0.3.7 && < 0.4
- cpp-options: -DWITH_JSON
+ vector >= 0.12 && < 0.14
default-language: Haskell2010
@@ -110,7 +97,7 @@ test-suite graphql-test
conduit,
exceptions,
graphql,
- hspec ^>= 2.9.1,
+ hspec ^>= 2.10.9,
hspec-expectations ^>= 0.8.2,
hspec-megaparsec ^>= 2.2.0,
megaparsec,
diff --git a/src/Language/GraphQL.hs b/src/Language/GraphQL.hs
index 4f3e8d9..949fd06 100644
--- a/src/Language/GraphQL.hs
+++ b/src/Language/GraphQL.hs
@@ -1,105 +1,5 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
-#ifdef WITH_JSON
--- | This module provides the functions to parse and execute @GraphQL@ queries.
---
--- The content of this module depends on the value of the __json__ flag, which
--- is currently on by default. This behavior will change in the future, the flag
--- will be switched off by default and then removed.
---
--- This documentation is generated with the enabled __json__ flag and functions
--- described here support JSON and are deprecated. JSON instances are provided
--- now by an additional package, __graphql-spice__. To start using the new
--- package create __cabal.project__ in the root directory of your project with
--- the following contents:
---
--- @
--- packages: .
--- constraints: graphql -json
--- @
---
--- Then add __graphql-spice__ as dependency.
---
--- The new version of this module defines only one function, @graphql@, which
--- works with the internal GraphQL value representation used by this lbirary.
--- Refer to @Language.GraphQL.JSON.graphql@ in __graphql-spice__ for the
--- function that accepts and returns JSON.
-module Language.GraphQL
- ( graphql
- , graphqlSubs
- ) where
-
-import Control.Monad.Catch (MonadCatch)
-import qualified Data.Aeson as Aeson
-import qualified Data.Aeson.Types as Aeson
-import qualified Data.HashMap.Strict as HashMap
-import Data.Maybe (catMaybes)
-import qualified Data.Sequence as Seq
-import Data.Text (Text)
-import Language.GraphQL.AST
-import Language.GraphQL.Error
-import Language.GraphQL.Execute
-import qualified Language.GraphQL.Validate as Validate
-import Language.GraphQL.Type.Schema (Schema)
-import Text.Megaparsec (parse)
-
-{-# DEPRECATED graphql "Use graphql-spice package instead" #-}
--- | If the text parses correctly as a @GraphQL@ query the query is
--- executed using the given 'Schema'.
-graphql :: MonadCatch m
- => Schema m -- ^ Resolvers.
- -> Text -- ^ Text representing a @GraphQL@ request document.
- -> m (Either (ResponseEventStream m Aeson.Value) Aeson.Object) -- ^ Response.
-graphql schema = graphqlSubs schema mempty mempty
-
-{-# DEPRECATED graphqlSubs "Use graphql-spice package instead" #-}
--- | If the text parses correctly as a @GraphQL@ query the substitution is
--- applied to the query and the query is then executed using to the given
--- 'Schema'.
-graphqlSubs :: MonadCatch m
- => Schema m -- ^ Resolvers.
- -> Maybe Text -- ^ Operation name.
- -> Aeson.Object -- ^ Variable substitution function.
- -> Text -- ^ Text representing a @GraphQL@ request document.
- -> m (Either (ResponseEventStream m Aeson.Value) Aeson.Object) -- ^ Response.
-graphqlSubs schema operationName variableValues document' =
- case parse document "" document' of
- Left errorBundle -> pure . formatResponse <$> parseError errorBundle
- Right parsed ->
- case validate parsed of
- Seq.Empty -> fmap formatResponse
- <$> execute schema operationName variableValues parsed
- errors -> pure $ pure
- $ HashMap.singleton "errors"
- $ Aeson.toJSON
- $ fromValidationError <$> errors
- where
- validate = Validate.document schema Validate.specifiedRules
- formatResponse (Response data'' Seq.Empty) = HashMap.singleton "data" data''
- formatResponse (Response data'' errors') = HashMap.fromList
- [ ("data", data'')
- , ("errors", Aeson.toJSON $ fromError <$> errors')
- ]
- fromError Error{..} = Aeson.object $ catMaybes
- [ Just ("message", Aeson.toJSON message)
- , toMaybe fromLocation "locations" locations
- , toMaybe fromPath "path" path
- ]
- fromValidationError Validate.Error{..} = Aeson.object
- [ ("message", Aeson.toJSON message)
- , ("locations", Aeson.listValue fromLocation locations)
- ]
- toMaybe _ _ [] = Nothing
- toMaybe f key xs = Just (key, Aeson.listValue f xs)
- fromPath (Segment segment) = Aeson.String segment
- fromPath (Index index) = Aeson.toJSON index
- fromLocation Location{..} = Aeson.object
- [ ("line", Aeson.toJSON line)
- , ("column", Aeson.toJSON column)
- ]
-#else
-- | This module provides the functions to parse and execute @GraphQL@ queries.
module Language.GraphQL
( graphql
@@ -144,4 +44,3 @@ graphql schema operationName variableValues document' =
, locations = locations
, path = []
}
-#endif
diff --git a/src/Language/GraphQL/AST/Document.hs b/src/Language/GraphQL/AST/Document.hs
index ea640df..131285d 100644
--- a/src/Language/GraphQL/AST/Document.hs
+++ b/src/Language/GraphQL/AST/Document.hs
@@ -464,6 +464,14 @@ data SchemaExtension
newtype Description = Description (Maybe Text)
deriving (Eq, Show)
+instance Semigroup Description
+ where
+ Description lhs <> Description rhs = Description $ lhs <> rhs
+
+instance Monoid Description
+ where
+ mempty = Description mempty
+
-- ** Types
-- | Type definitions describe various user-defined types.
diff --git a/src/Language/GraphQL/AST/Encoder.hs b/src/Language/GraphQL/AST/Encoder.hs
index 54967ea..120fb64 100644
--- a/src/Language/GraphQL/AST/Encoder.hs
+++ b/src/Language/GraphQL/AST/Encoder.hs
@@ -14,10 +14,11 @@ module Language.GraphQL.AST.Encoder
, operationType
, pretty
, type'
+ , typeSystemDefinition
, value
) where
-import Data.Foldable (fold)
+import Data.Foldable (fold, Foldable (..))
import qualified Data.List.NonEmpty as NonEmpty
import Data.Text (Text)
import qualified Data.Text as Text
@@ -28,6 +29,7 @@ import qualified Data.Text.Lazy.Builder as Builder
import Data.Text.Lazy.Builder.Int (decimal)
import Data.Text.Lazy.Builder.RealFloat (realFloat)
import qualified Language.GraphQL.AST.Document as Full
+import qualified Language.GraphQL.AST.DirectiveLocation as DirectiveLocation
-- | Instructs the encoder whether the GraphQL document should be minified or
-- pretty printed.
@@ -54,7 +56,246 @@ document formatter defs
encodeDocument = foldr executableDefinition [] defs
executableDefinition (Full.ExecutableDefinition executableDefinition') acc =
definition formatter executableDefinition' : acc
- executableDefinition _ acc = acc
+ executableDefinition (Full.TypeSystemDefinition typeSystemDefinition' _location) acc =
+ typeSystemDefinition formatter typeSystemDefinition' : acc
+ executableDefinition (Full.TypeSystemExtension typeSystemExtension' _location) acc =
+ typeSystemExtension formatter typeSystemExtension' : acc
+
+directiveLocation :: DirectiveLocation.DirectiveLocation -> Lazy.Text
+directiveLocation = Lazy.Text.pack . show
+
+withLineBreak :: Formatter -> Lazy.Text.Text -> Lazy.Text.Text
+withLineBreak formatter encodeDefinition
+ | Pretty _ <- formatter = Lazy.Text.snoc encodeDefinition '\n'
+ | Minified <- formatter = encodeDefinition
+
+typeSystemExtension :: Formatter -> Full.TypeSystemExtension -> Lazy.Text
+typeSystemExtension formatter = \case
+ Full.SchemaExtension schemaExtension' ->
+ schemaExtension formatter schemaExtension'
+ Full.TypeExtension typeExtension' -> typeExtension formatter typeExtension'
+
+schemaExtension :: Formatter -> Full.SchemaExtension -> Lazy.Text
+schemaExtension formatter = \case
+ Full.SchemaOperationExtension operationDirectives operationTypeDefinitions' ->
+ withLineBreak formatter
+ $ "extend schema "
+ <> optempty (directives formatter) operationDirectives
+ <> bracesList formatter (operationTypeDefinition formatter) (NonEmpty.toList operationTypeDefinitions')
+ Full.SchemaDirectivesExtension operationDirectives -> "extend schema "
+ <> optempty (directives formatter) (NonEmpty.toList operationDirectives)
+
+typeExtension :: Formatter -> Full.TypeExtension -> Lazy.Text
+typeExtension formatter = \case
+ Full.ScalarTypeExtension name' directives'
+ -> "extend scalar "
+ <> Lazy.Text.fromStrict name'
+ <> directives formatter (NonEmpty.toList directives')
+ Full.ObjectTypeFieldsDefinitionExtension name' ifaces' directives' fields'
+ -> "extend type "
+ <> Lazy.Text.fromStrict name'
+ <> optempty (" " <>) (implementsInterfaces ifaces')
+ <> optempty (directives formatter) directives'
+ <> eitherFormat formatter " " ""
+ <> bracesList formatter (fieldDefinition nextFormatter) (NonEmpty.toList fields')
+ Full.ObjectTypeDirectivesExtension name' ifaces' directives'
+ -> "extend type "
+ <> Lazy.Text.fromStrict name'
+ <> optempty (" " <>) (implementsInterfaces ifaces')
+ <> optempty (directives formatter) (NonEmpty.toList directives')
+ Full.ObjectTypeImplementsInterfacesExtension name' ifaces'
+ -> "extend type "
+ <> Lazy.Text.fromStrict name'
+ <> optempty (" " <>) (implementsInterfaces ifaces')
+ Full.InterfaceTypeFieldsDefinitionExtension name' directives' fields'
+ -> "extend interface "
+ <> Lazy.Text.fromStrict name'
+ <> optempty (directives formatter) directives'
+ <> eitherFormat formatter " " ""
+ <> bracesList formatter (fieldDefinition nextFormatter) (NonEmpty.toList fields')
+ Full.InterfaceTypeDirectivesExtension name' directives'
+ -> "extend interface "
+ <> Lazy.Text.fromStrict name'
+ <> optempty (directives formatter) (NonEmpty.toList directives')
+ Full.UnionTypeUnionMemberTypesExtension name' directives' members'
+ -> "extend union "
+ <> Lazy.Text.fromStrict name'
+ <> optempty (directives formatter) directives'
+ <> eitherFormat formatter " " ""
+ <> unionMemberTypes formatter members'
+ Full.UnionTypeDirectivesExtension name' directives'
+ -> "extend union "
+ <> Lazy.Text.fromStrict name'
+ <> optempty (directives formatter) (NonEmpty.toList directives')
+ Full.EnumTypeEnumValuesDefinitionExtension name' directives' members'
+ -> "extend enum "
+ <> Lazy.Text.fromStrict name'
+ <> optempty (directives formatter) directives'
+ <> eitherFormat formatter " " ""
+ <> bracesList formatter (enumValueDefinition formatter) (NonEmpty.toList members')
+ Full.EnumTypeDirectivesExtension name' directives'
+ -> "extend enum "
+ <> Lazy.Text.fromStrict name'
+ <> optempty (directives formatter) (NonEmpty.toList directives')
+ Full.InputObjectTypeInputFieldsDefinitionExtension name' directives' fields'
+ -> "extend input "
+ <> Lazy.Text.fromStrict name'
+ <> optempty (directives formatter) directives'
+ <> eitherFormat formatter " " ""
+ <> bracesList formatter (inputValueDefinition nextFormatter) (NonEmpty.toList fields')
+ Full.InputObjectTypeDirectivesExtension name' directives'
+ -> "extend input "
+ <> Lazy.Text.fromStrict name'
+ <> optempty (directives formatter) (NonEmpty.toList directives')
+ where
+ nextFormatter = incrementIndent formatter
+
+-- | Converts a t'Full.TypeSystemDefinition' into a string.
+typeSystemDefinition :: Formatter -> Full.TypeSystemDefinition -> Lazy.Text
+typeSystemDefinition formatter = \case
+ Full.SchemaDefinition operationDirectives operationTypeDefinitions' ->
+ withLineBreak formatter
+ $ "schema "
+ <> optempty (directives formatter) operationDirectives
+ <> bracesList formatter (operationTypeDefinition formatter) (NonEmpty.toList operationTypeDefinitions')
+ Full.TypeDefinition typeDefinition' -> typeDefinition formatter typeDefinition'
+ Full.DirectiveDefinition description' name' arguments' locations
+ -> description formatter description'
+ <> "@"
+ <> Lazy.Text.fromStrict name'
+ <> argumentsDefinition formatter arguments'
+ <> " on"
+ <> pipeList formatter (directiveLocation <$> locations)
+
+operationTypeDefinition :: Formatter -> Full.OperationTypeDefinition -> Lazy.Text.Text
+operationTypeDefinition formatter (Full.OperationTypeDefinition operationType' namedType')
+ = indentLine (incrementIndent formatter)
+ <> operationType formatter operationType'
+ <> colon formatter
+ <> Lazy.Text.fromStrict namedType'
+
+fieldDefinition :: Formatter -> Full.FieldDefinition -> Lazy.Text.Text
+fieldDefinition formatter fieldDefinition' =
+ let Full.FieldDefinition description' name' arguments' type'' directives' = fieldDefinition'
+ in optempty (description formatter) description'
+ <> indentLine formatter
+ <> Lazy.Text.fromStrict name'
+ <> argumentsDefinition formatter arguments'
+ <> colon formatter
+ <> type' type''
+ <> optempty (directives formatter) directives'
+
+argumentsDefinition :: Formatter -> Full.ArgumentsDefinition -> Lazy.Text.Text
+argumentsDefinition formatter (Full.ArgumentsDefinition arguments') =
+ parensCommas formatter (argumentDefinition formatter) arguments'
+
+argumentDefinition :: Formatter -> Full.InputValueDefinition -> Lazy.Text.Text
+argumentDefinition formatter definition' =
+ let Full.InputValueDefinition description' name' type'' defaultValue' directives' = definition'
+ in optempty (description formatter) description'
+ <> Lazy.Text.fromStrict name'
+ <> colon formatter
+ <> type' type''
+ <> maybe mempty (defaultValue formatter . Full.node) defaultValue'
+ <> directives formatter directives'
+
+inputValueDefinition :: Formatter -> Full.InputValueDefinition -> Lazy.Text.Text
+inputValueDefinition formatter definition' =
+ let Full.InputValueDefinition description' name' type'' defaultValue' directives' = definition'
+ in optempty (description formatter) description'
+ <> indentLine formatter
+ <> Lazy.Text.fromStrict name'
+ <> colon formatter
+ <> type' type''
+ <> maybe mempty (defaultValue formatter . Full.node) defaultValue'
+ <> directives formatter directives'
+
+typeDefinition :: Formatter -> Full.TypeDefinition -> Lazy.Text
+typeDefinition formatter = \case
+ Full.ScalarTypeDefinition description' name' directives'
+ -> optempty (description formatter) description'
+ <> "scalar "
+ <> Lazy.Text.fromStrict name'
+ <> optempty (directives formatter) directives'
+ Full.ObjectTypeDefinition description' name' ifaces' directives' fields'
+ -> optempty (description formatter) description'
+ <> "type "
+ <> Lazy.Text.fromStrict name'
+ <> optempty (" " <>) (implementsInterfaces ifaces')
+ <> optempty (directives formatter) directives'
+ <> eitherFormat formatter " " ""
+ <> bracesList formatter (fieldDefinition nextFormatter) fields'
+ Full.InterfaceTypeDefinition description' name' directives' fields'
+ -> optempty (description formatter) description'
+ <> "interface "
+ <> Lazy.Text.fromStrict name'
+ <> optempty (directives formatter) directives'
+ <> eitherFormat formatter " " ""
+ <> bracesList formatter (fieldDefinition nextFormatter) fields'
+ Full.UnionTypeDefinition description' name' directives' members'
+ -> optempty (description formatter) description'
+ <> "union "
+ <> Lazy.Text.fromStrict name'
+ <> optempty (directives formatter) directives'
+ <> eitherFormat formatter " " ""
+ <> unionMemberTypes formatter members'
+ Full.EnumTypeDefinition description' name' directives' members'
+ -> optempty (description formatter) description'
+ <> "enum "
+ <> Lazy.Text.fromStrict name'
+ <> optempty (directives formatter) directives'
+ <> eitherFormat formatter " " ""
+ <> bracesList formatter (enumValueDefinition formatter) members'
+ Full.InputObjectTypeDefinition description' name' directives' fields'
+ -> optempty (description formatter) description'
+ <> "input "
+ <> Lazy.Text.fromStrict name'
+ <> optempty (directives formatter) directives'
+ <> eitherFormat formatter " " ""
+ <> bracesList formatter (inputValueDefinition nextFormatter) fields'
+ where
+ nextFormatter = incrementIndent formatter
+
+implementsInterfaces :: Foldable t => Full.ImplementsInterfaces t -> Lazy.Text
+implementsInterfaces (Full.ImplementsInterfaces interfaces)
+ | null interfaces = mempty
+ | otherwise = Lazy.Text.fromStrict
+ $ Text.append "implements "
+ $ Text.intercalate " & "
+ $ toList interfaces
+
+unionMemberTypes :: Foldable t => Formatter -> Full.UnionMemberTypes t -> Lazy.Text
+unionMemberTypes formatter (Full.UnionMemberTypes memberTypes)
+ | null memberTypes = mempty
+ | otherwise = Lazy.Text.append "="
+ $ pipeList formatter
+ $ Lazy.Text.fromStrict
+ <$> toList memberTypes
+
+pipeList :: Foldable t => Formatter -> t Lazy.Text -> Lazy.Text
+pipeList Minified = (" " <>) . Lazy.Text.intercalate " | " . toList
+pipeList (Pretty _) = Lazy.Text.concat
+ . fmap (("\n" <> indentSymbol <> "| ") <>)
+ . toList
+
+enumValueDefinition :: Formatter -> Full.EnumValueDefinition -> Lazy.Text
+enumValueDefinition (Pretty _) enumValue =
+ let Full.EnumValueDefinition description' name' directives' = enumValue
+ formatter = Pretty 1
+ in description formatter description'
+ <> indentLine formatter
+ <> Lazy.Text.fromStrict name'
+ <> directives formatter directives'
+enumValueDefinition Minified enumValue =
+ let Full.EnumValueDefinition description' name' directives' = enumValue
+ in description Minified description'
+ <> Lazy.Text.fromStrict name'
+ <> directives Minified directives'
+
+description :: Formatter -> Full.Description -> Lazy.Text.Text
+description _formatter (Full.Description Nothing) = ""
+description formatter (Full.Description (Just description')) =
+ stringValue formatter description'
-- | Converts a t'Full.ExecutableDefinition' into a string.
definition :: Formatter -> Full.ExecutableDefinition -> Lazy.Text
@@ -100,7 +341,7 @@ variableDefinition formatter variableDefinition' =
let Full.VariableDefinition variableName variableType defaultValue' _ =
variableDefinition'
in variable variableName
- <> eitherFormat formatter ": " ":"
+ <> colon formatter
<> type' variableType
<> maybe mempty (defaultValue formatter . Full.node) defaultValue'
@@ -127,20 +368,26 @@ indent :: (Integral a) => a -> Lazy.Text
indent indentation = Lazy.Text.replicate (fromIntegral indentation) indentSymbol
selection :: Formatter -> Full.Selection -> Lazy.Text
-selection formatter = Lazy.Text.append indent' . encodeSelection
+selection formatter = Lazy.Text.append (indentLine formatter')
+ . encodeSelection
where
encodeSelection (Full.FieldSelection fieldSelection) =
- field incrementIndent fieldSelection
+ field formatter' fieldSelection
encodeSelection (Full.InlineFragmentSelection fragmentSelection) =
- inlineFragment incrementIndent fragmentSelection
+ inlineFragment formatter' fragmentSelection
encodeSelection (Full.FragmentSpreadSelection fragmentSelection) =
- fragmentSpread incrementIndent fragmentSelection
- incrementIndent
- | Pretty indentation <- formatter = Pretty $ indentation + 1
- | otherwise = Minified
- indent'
- | Pretty indentation <- formatter = indent $ indentation + 1
- | otherwise = ""
+ fragmentSpread formatter' fragmentSelection
+ formatter' = incrementIndent formatter
+
+indentLine :: Formatter -> Lazy.Text
+indentLine formatter
+ | Pretty indentation <- formatter = indent indentation
+ | otherwise = ""
+
+incrementIndent :: Formatter -> Formatter
+incrementIndent formatter
+ | Pretty indentation <- formatter = Pretty $ indentation + 1
+ | otherwise = Minified
colon :: Formatter -> Lazy.Text
colon formatter = eitherFormat formatter ": " ":"
@@ -198,8 +445,10 @@ directive formatter (Full.Directive name args _)
= "@" <> Lazy.Text.fromStrict name <> optempty (arguments formatter) args
directives :: Formatter -> [Full.Directive] -> Lazy.Text
-directives Minified = spaces (directive Minified)
-directives formatter = Lazy.Text.cons ' ' . spaces (directive formatter)
+directives Minified values = spaces (directive Minified) values
+directives formatter values
+ | null values = ""
+ | otherwise = Lazy.Text.cons ' ' $ spaces (directive formatter) values
-- | Converts a 'Full.Value' into a string.
value :: Formatter -> Full.Value -> Lazy.Text
diff --git a/src/Language/GraphQL/Execute.hs b/src/Language/GraphQL/Execute.hs
index 5ceb616..bbacdd2 100644
--- a/src/Language/GraphQL/Execute.hs
+++ b/src/Language/GraphQL/Execute.hs
@@ -39,6 +39,7 @@ import qualified Data.List.NonEmpty as NonEmpty
import Data.Maybe (fromMaybe)
import Data.Sequence (Seq)
import qualified Data.Sequence as Seq
+import qualified Data.Vector as Vector
import Data.Text (Text)
import qualified Data.Text as Text
import Data.Typeable (cast)
@@ -466,12 +467,12 @@ completeValue :: (MonadCatch m, Serialize a)
completeValue (Out.isNonNullType -> False) _ _ Type.Null =
pure null
completeValue outputType@(Out.ListBaseType listType) fields errorPath (Type.List list)
- = foldM go (0, []) list >>= coerceResult outputType . List . snd
+ = foldM go Vector.empty list >>= coerceResult outputType . List . Vector.toList
where
- go (index, accumulator) listItem = do
- let updatedPath = Index index : errorPath
- completedValue <- completeValue listType fields updatedPath listItem
- pure (index + 1, completedValue : accumulator)
+ go accumulator listItem =
+ let updatedPath = Index (Vector.length accumulator) : errorPath
+ in Vector.snoc accumulator
+ <$> completeValue listType fields updatedPath listItem
completeValue outputType@(Out.ScalarBaseType _) _ _ (Type.Int int) =
coerceResult outputType $ Int int
completeValue outputType@(Out.ScalarBaseType _) _ _ (Type.Boolean boolean) =
diff --git a/src/Language/GraphQL/Execute/Coerce.hs b/src/Language/GraphQL/Execute/Coerce.hs
index 4725d74..54fc1c1 100644
--- a/src/Language/GraphQL/Execute/Coerce.hs
+++ b/src/Language/GraphQL/Execute/Coerce.hs
@@ -5,14 +5,8 @@
{-# LANGUAGE ExplicitForAll #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns #-}
-{-# LANGUAGE CPP #-}
-- | Types and functions used for input and result coercion.
---
--- JSON instances in this module are only available with the __json__
--- flag that is currently on by default, but will be disabled in the future.
--- Refer to the documentation in the 'Language.GraphQL' module and to
--- the __graphql-spice__ package.
module Language.GraphQL.Execute.Coerce
( Output(..)
, Serialize(..)
@@ -21,10 +15,6 @@ module Language.GraphQL.Execute.Coerce
, matchFieldValues
) where
-#ifdef WITH_JSON
-import qualified Data.Aeson as Aeson
-import Data.Scientific (toBoundedInteger, toRealFloat)
-#endif
import Data.Int (Int32)
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
@@ -232,69 +222,3 @@ instance Serialize Type.Value where
$ HashMap.fromList
$ OrderedMap.toList object
serialize _ _ = Nothing
-
-#ifdef WITH_JSON
-instance Serialize Aeson.Value where
- serialize (Out.ScalarBaseType scalarType) value
- | Type.ScalarType "Int" _ <- scalarType
- , Int int <- value = Just $ Aeson.toJSON int
- | Type.ScalarType "Float" _ <- scalarType
- , Float float <- value = Just $ Aeson.toJSON float
- | Type.ScalarType "String" _ <- scalarType
- , String string <- value = Just $ Aeson.String string
- | Type.ScalarType "ID" _ <- scalarType
- , String string <- value = Just $ Aeson.String string
- | Type.ScalarType "Boolean" _ <- scalarType
- , Boolean boolean <- value = Just $ Aeson.Bool boolean
- serialize _ (Enum enum) = Just $ Aeson.String enum
- serialize _ (List list) = Just $ Aeson.toJSON list
- serialize _ (Object object) = Just
- $ Aeson.object
- $ OrderedMap.toList
- $ Aeson.toJSON <$> object
- serialize _ _ = Nothing
- null = Aeson.Null
-
-instance VariableValue Aeson.Value where
- coerceVariableValue _ Aeson.Null = Just Type.Null
- coerceVariableValue (In.ScalarBaseType scalarType) value
- | (Aeson.String stringValue) <- value = Just $ Type.String stringValue
- | (Aeson.Bool booleanValue) <- value = Just $ Type.Boolean booleanValue
- | (Aeson.Number numberValue) <- value
- , (Type.ScalarType "Float" _) <- scalarType =
- Just $ Type.Float $ toRealFloat numberValue
- | (Aeson.Number numberValue) <- value = -- ID or Int
- Type.Int <$> toBoundedInteger numberValue
- coerceVariableValue (In.EnumBaseType _) (Aeson.String stringValue) =
- Just $ Type.Enum stringValue
- coerceVariableValue (In.InputObjectBaseType objectType) value
- | (Aeson.Object objectValue) <- value = do
- let (In.InputObjectType _ _ inputFields) = objectType
- (newObjectValue, resultMap) <- foldWithKey objectValue inputFields
- if HashMap.null newObjectValue
- then Just $ Type.Object resultMap
- else Nothing
- where
- foldWithKey objectValue = HashMap.foldrWithKey matchFieldValues'
- $ Just (objectValue, HashMap.empty)
- matchFieldValues' _ _ Nothing = Nothing
- matchFieldValues' fieldName inputField (Just (objectValue, resultMap)) =
- let (In.InputField _ fieldType _) = inputField
- insert = flip (HashMap.insert fieldName) resultMap
- newObjectValue = HashMap.delete fieldName objectValue
- in case HashMap.lookup fieldName objectValue of
- Just variableValue -> do
- coerced <- coerceVariableValue fieldType variableValue
- pure (newObjectValue, insert coerced)
- Nothing -> Just (objectValue, resultMap)
- coerceVariableValue (In.ListBaseType listType) value
- | (Aeson.Array arrayValue) <- value =
- Type.List <$> foldr foldVector (Just []) arrayValue
- | otherwise = coerceVariableValue listType value
- where
- foldVector _ Nothing = Nothing
- foldVector variableValue (Just list) = do
- coerced <- coerceVariableValue listType variableValue
- pure $ coerced : list
- coerceVariableValue _ _ = Nothing
-#endif
diff --git a/src/Test/Hspec/GraphQL.hs b/src/Test/Hspec/GraphQL.hs
deleted file mode 100644
index a848c15..0000000
--- a/src/Test/Hspec/GraphQL.hs
+++ /dev/null
@@ -1,49 +0,0 @@
-{- This Source Code Form is subject to the terms of the Mozilla Public License,
- v. 2.0. If a copy of the MPL was not distributed with this file, You can
- obtain one at https://mozilla.org/MPL/2.0/. -}
-
-{-# LANGUAGE CPP #-}
-
-#ifdef WITH_JSON
-{-# LANGUAGE ExplicitForAll #-}
-{-# LANGUAGE OverloadedStrings #-}
-
--- | Test helpers.
-module Test.Hspec.GraphQL {-# DEPRECATED "Use graphql-spice package instead" #-}
- ( shouldResolve
- , shouldResolveTo
- ) where
-
-import Control.Monad.Catch (MonadCatch)
-import qualified Data.Aeson as Aeson
-import qualified Data.HashMap.Strict as HashMap
-import Data.Text (Text)
-import Language.GraphQL.Error
-import Test.Hspec.Expectations (Expectation, expectationFailure, shouldBe, shouldNotSatisfy)
-
--- | Asserts that a query resolves to some value.
-shouldResolveTo :: MonadCatch m
- => Either (ResponseEventStream m Aeson.Value) Aeson.Object
- -> Aeson.Object
- -> Expectation
-shouldResolveTo (Right actual) expected = actual `shouldBe` expected
-shouldResolveTo _ _ = expectationFailure
- "the query is expected to resolve to a value, but it resolved to an event stream"
-
--- | Asserts that the response doesn't contain any errors.
-shouldResolve :: MonadCatch m
- => (Text -> IO (Either (ResponseEventStream m Aeson.Value) Aeson.Object))
- -> Text
- -> Expectation
-shouldResolve executor query = do
- actual <- executor query
- case actual of
- Right response ->
- response `shouldNotSatisfy` HashMap.member "errors"
- _ -> expectationFailure
- "the query is expected to resolve to a value, but it resolved to an event stream"
-#else
-module Test.Hspec.GraphQL {-# DEPRECATED "Use graphql-spice package instead" #-}
- (
- ) where
-#endif
diff --git a/tests/Language/GraphQL/AST/DocumentSpec.hs b/tests/Language/GraphQL/AST/DocumentSpec.hs
index ca13e17..d09d6b1 100644
--- a/tests/Language/GraphQL/AST/DocumentSpec.hs
+++ b/tests/Language/GraphQL/AST/DocumentSpec.hs
@@ -18,3 +18,9 @@ spec = do
]
expected = "{ field1: 1.2, field2: null }"
in show object `shouldBe` expected
+
+ describe "Description" $
+ it "keeps content when merging with no description" $
+ let expected = Description $ Just "Left description"
+ actual = expected <> Description Nothing
+ in actual `shouldBe` expected
diff --git a/tests/Language/GraphQL/AST/EncoderSpec.hs b/tests/Language/GraphQL/AST/EncoderSpec.hs
index febd6fd..3fa6a02 100644
--- a/tests/Language/GraphQL/AST/EncoderSpec.hs
+++ b/tests/Language/GraphQL/AST/EncoderSpec.hs
@@ -4,6 +4,7 @@ module Language.GraphQL.AST.EncoderSpec
( spec
) where
+import Data.List.NonEmpty (NonEmpty(..))
import qualified Language.GraphQL.AST.Document as Full
import Language.GraphQL.AST.Encoder
import Language.GraphQL.TH
@@ -178,3 +179,91 @@ spec = do
it "produces lowercase mutation operation type" $
let actual = operationType pretty Full.Mutation
in actual `shouldBe` "mutation"
+
+ describe "typeSystemDefinition" $ do
+ it "produces a schema with an indented operation type definition" $
+ let queryType = Full.OperationTypeDefinition Full.Query "QueryRootType"
+ 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'
+ actual = typeSystemDefinition pretty definition'
+ in actual `shouldBe` expected
+
+ it "encodes a scalar type definition" $
+ let uuidType = Full.ScalarTypeDefinition mempty "UUID" mempty
+ definition' = Full.TypeDefinition uuidType
+ expected = "scalar UUID"
+ actual = typeSystemDefinition pretty definition'
+ in actual `shouldBe` expected
+
+ it "encodes an interface definition" $
+ let someType = Full.TypeNamed "String"
+ argument = Full.InputValueDefinition mempty "arg" someType Nothing mempty
+ arguments = Full.ArgumentsDefinition [argument]
+ definition' = Full.TypeDefinition
+ $ Full.InterfaceTypeDefinition mempty "UUID" mempty
+ $ pure
+ $ Full.FieldDefinition mempty "value" arguments someType mempty
+ expected = [gql|
+ interface UUID {
+ value(arg: String): String
+ }
+ |]
+ actual = typeSystemDefinition pretty definition'
+ in actual `shouldBe` expected
+
+ it "encodes an union definition" $
+ let definition' = Full.TypeDefinition
+ $ Full.UnionTypeDefinition mempty "SearchResult" mempty
+ $ Full.UnionMemberTypes ["Photo", "Person"]
+ expected = [gql|
+ union SearchResult =
+ | Photo
+ | Person
+ |]
+ actual = typeSystemDefinition pretty definition'
+ in actual `shouldBe` expected
+
+ it "encodes an enum definition" $
+ let values =
+ [ Full.EnumValueDefinition mempty "NORTH" mempty
+ , Full.EnumValueDefinition mempty "EAST" mempty
+ , Full.EnumValueDefinition mempty "SOUTH" mempty
+ , Full.EnumValueDefinition mempty "WEST" mempty
+ ]
+ definition' = Full.TypeDefinition
+ $ Full.EnumTypeDefinition mempty "Direction" mempty values
+ expected = [gql|
+ enum Direction {
+ NORTH
+ EAST
+ SOUTH
+ WEST
+ }
+ |]
+ actual = typeSystemDefinition pretty definition'
+ in actual `shouldBe` expected
+
+ it "encodes an input type" $
+ let intType = Full.TypeNonNull $ Full.NonNullTypeNamed "Int"
+ stringType = Full.TypeNamed "String"
+ fields =
+ [ Full.InputValueDefinition mempty "a" stringType Nothing mempty
+ , Full.InputValueDefinition mempty "b" intType Nothing mempty
+ ]
+ definition' = Full.TypeDefinition
+ $ Full.InputObjectTypeDefinition mempty "ExampleInputObject" mempty fields
+ expected = [gql|
+ input ExampleInputObject {
+ a: String
+ b: Int!
+ }
+ |]
+ actual = typeSystemDefinition pretty definition'
+ in actual `shouldBe` expected
diff --git a/tests/Language/GraphQL/ExecuteSpec.hs b/tests/Language/GraphQL/ExecuteSpec.hs
index c313df0..65033ae 100644
--- a/tests/Language/GraphQL/ExecuteSpec.hs
+++ b/tests/Language/GraphQL/ExecuteSpec.hs
@@ -66,8 +66,9 @@ queryType :: Out.ObjectType IO
queryType = Out.ObjectType "Query" Nothing []
$ HashMap.fromList
[ ("philosopher", ValueResolver philosopherField philosopherResolver)
- , ("genres", ValueResolver genresField genresResolver)
+ , ("throwing", ValueResolver throwingField throwingResolver)
, ("count", ValueResolver countField countResolver)
+ , ("sequence", ValueResolver sequenceField sequenceResolver)
]
where
philosopherField =
@@ -75,15 +76,22 @@ queryType = Out.ObjectType "Query" Nothing []
$ HashMap.singleton "id"
$ In.Argument Nothing (In.NamedScalarType id) Nothing
philosopherResolver = pure $ Object mempty
- genresField =
+ throwingField =
let fieldType = Out.ListType $ Out.NonNullScalarType string
in Out.Field Nothing fieldType HashMap.empty
- genresResolver :: Resolve IO
- genresResolver = throwM PhilosopherException
+ throwingResolver :: Resolve IO
+ throwingResolver = throwM PhilosopherException
countField =
let fieldType = Out.NonNullScalarType int
in Out.Field Nothing fieldType HashMap.empty
countResolver = pure ""
+ sequenceField =
+ let fieldType = Out.ListType $ Out.NonNullScalarType int
+ in Out.Field Nothing fieldType HashMap.empty
+ sequenceResolver = pure intSequence
+
+intSequence :: Value
+intSequence = Type.List [Type.Int 1, Type.Int 2, Type.Int 3]
musicType :: Out.ObjectType IO
musicType = Out.ObjectType "Music" Nothing []
@@ -344,14 +352,14 @@ spec =
in sourceQuery `shouldResolveTo` expected
it "gives location information for failed result coercion" $
- let data'' = Object $ HashMap.singleton "genres" Null
+ let data'' = Object $ HashMap.singleton "throwing" Null
executionErrors = pure $ Error
{ message = "PhilosopherException"
, locations = [Location 1 3]
- , path = [Segment "genres"]
+ , path = [Segment "throwing"]
}
expected = Response data'' executionErrors
- sourceQuery = "{ genres }"
+ sourceQuery = "{ throwing }"
in sourceQuery `shouldResolveTo` expected
it "sets data to null if a root field isn't nullable" $
@@ -375,6 +383,12 @@ spec =
sourceQuery = "{ philosopher(id: \"1\") { firstLanguage } }"
in sourceQuery `shouldResolveTo` expected
+ it "returns list elements in the original order" $
+ let data'' = Object $ HashMap.singleton "sequence" intSequence
+ expected = Response data'' mempty
+ sourceQuery = "{ sequence }"
+ in sourceQuery `shouldResolveTo` expected
+
context "queryError" $ do
let namedQuery name = "query " <> name <> " { philosopher(id: \"1\") { interest } }"
twoQueries = namedQuery "A" <> " " <> namedQuery "B"
generated by cgit v1.2.3 (git 2.26.2) at 2026-10-02 07:23:36 +0000