Compare commits
29 Commits
Author | SHA1 | Date |
---|---|---|
Eugen Wissner | 9232e08eb9 | |
Eugen Wissner | 500cff20eb | |
Eugen Wissner | 387d158bd1 | |
Dmitrii Skurikhin | 2760bd8ee1 | |
Dmitrii Skurikhin | 30d6a0a58d | |
Eugen Wissner | 613e929d91 | |
Eugen Wissner | c0e5e30e76 | |
Eugen Wissner | 67bebf853c | |
Eugen Wissner | e8b82122c6 | |
Eugen Wissner | a6bd2370b6 | |
Eugen Wissner | b4a3c98114 | |
Eugen Wissner | cb5270b197 | |
Eugen Wissner | 3ef27f9d11 | |
Eugen Wissner | ba710a3c96 | |
Eugen Wissner | d257d05d4e | |
Eugen Wissner | adffa185bb | |
Eugen Wissner | f4ed06741d | |
Eugen Wissner | 8efb08fda1 | |
Eugen Wissner | d9a2937b55 | |
Eugen Wissner | f4f076fa59 | |
Eugen Wissner | 6d951491be | |
Eugen Wissner | dd8f312cb3 | |
Eugen Wissner | d82d5a36b3 | |
Eugen Wissner | 44dc80bb37 | |
Eugen Wissner | fdf5914626 | |
Eugen Wissner | 78ee76f9d5 | |
Eugen Wissner | 56d88310df | |
Eugen Wissner | e3a495a778 | |
Eugen Wissner | 62f3c34bfe |
|
@ -9,3 +9,6 @@
|
|||
cabal.sandbox.config
|
||||
cabal.project.local
|
||||
/graphql.cabal
|
||||
|
||||
# GHC
|
||||
*.hi
|
||||
|
|
59
CHANGELOG.md
59
CHANGELOG.md
|
@ -1,9 +1,62 @@
|
|||
# Change Log
|
||||
# Changelog
|
||||
All notable changes to this project will be documented in this file.
|
||||
|
||||
The format is based on
|
||||
[Keep a Changelog](https://keepachangelog.com/en/1.0.0/),
|
||||
and this project adheres to
|
||||
[Haskell Package Versioning Policy](https://pvp.haskell.org/).
|
||||
|
||||
## [Unreleased]
|
||||
|
||||
## [0.7.0.0] - 2020-05-11
|
||||
### Fixed
|
||||
- Result of null encoding
|
||||
- Block strings encoding
|
||||
- Result of tab and newline encoding
|
||||
|
||||
### Added
|
||||
- AST for the GraphQL schema.
|
||||
- Type system definition parser.
|
||||
- `Trans.argument`.
|
||||
- Schema extension parser.
|
||||
- Contributing guidelines.
|
||||
- `Schema.resolversToMap` (intended for to be used internally).
|
||||
|
||||
### Changed
|
||||
- Rename `AST.Definition` into `AST.Document.ExecutableDefinition`.
|
||||
`AST.Document.TypeSystemDefinition` and `AST.Document.TypeSystemExtension`
|
||||
can also be definitions.
|
||||
- Move all AST data to `AST.Document` and reexport them.
|
||||
- Rename `AST.OperationSelectionSet` to `AST.Document.SelectionSet`.
|
||||
- Make `Schema.Subs` a `Data.HashMap.Strict` (was a function
|
||||
`key -> Maybe value` before).
|
||||
- Make `AST.Lexer.at` a text (symbol) parser. It was a char before and is
|
||||
`symbol "@"` now.
|
||||
- Replace `MonadIO` with a plain `Monad`. Since the tests don't use IO,
|
||||
set the inner monad to `Identity`.
|
||||
- `NonEmpty (Resolver m)` is now `HashMap Text (NonEmpty (Resolver m))`. Root
|
||||
operation type can be any type, therefore a hashmap is needed. Since types
|
||||
cannot be empty, we save the list of resolvers in the type as a non-empty
|
||||
list. Currently only "Query" and "Mutation" are supported as types. For more
|
||||
schema support is required. The executor checks now if the type in the query
|
||||
matches the type of the provided root resolvers.
|
||||
|
||||
### Removed
|
||||
- `AST.Field`, `AST.InlineFragment` and `AST.FragmentSpread`.
|
||||
These types are only used in `AST.Selection` and `AST.Selection` contains now
|
||||
3 corresponding data constructors, `Field`, `InlineFragment` and
|
||||
`FragmentSpread`, instead of separate types. It simplifies pattern matching
|
||||
and doesn't make the code less typesafe.
|
||||
- `Schema.scalarA`.
|
||||
- `Schema.wrappedScalarA`.
|
||||
- `Schema.wrappedObjectA`.
|
||||
- `Schema.objectA`.
|
||||
- `AST.Argument`. Replaced with `AST.Arguments` which holds all arguments as a
|
||||
key/value map.
|
||||
|
||||
## [0.6.1.0] - 2019-12-23
|
||||
### Fixed
|
||||
- Parsing multiple string arguments, such as
|
||||
- Parsing multiple string arguments, such as
|
||||
`login(username: "username", password: "password")` would fail on the comma
|
||||
due to strings not having a space consumer.
|
||||
- Fragment spread is evaluated based on the `__typename` resolver. If the
|
||||
|
@ -162,6 +215,8 @@ All notable changes to this project will be documented in this file.
|
|||
### Added
|
||||
- Data types for the GraphQL language.
|
||||
|
||||
[Unreleased]: https://github.com/caraus-ecms/graphql/compare/v0.6.1.0...HEAD
|
||||
[0.7.0.0]: https://github.com/caraus-ecms/graphql/compare/v0.6.1.0...v0.7.0.0
|
||||
[0.6.1.0]: https://github.com/caraus-ecms/graphql/compare/v0.6.0.0...v0.6.1.0
|
||||
[0.6.0.0]: https://github.com/caraus-ecms/graphql/compare/v0.5.1.0...v0.6.0.0
|
||||
[0.5.1.0]: https://github.com/caraus-ecms/graphql/compare/v0.5.0.1...v0.5.1.0
|
||||
|
|
|
@ -0,0 +1,31 @@
|
|||
# Contributing guidelines
|
||||
|
||||
## Testing
|
||||
|
||||
To ensure all code changes adhere to existing code quality standards, some
|
||||
automatic checks can be run locally.
|
||||
|
||||
Ensure that the code builds without warnings and passes the tests:
|
||||
|
||||
```sh
|
||||
stack test --pedantic
|
||||
```
|
||||
|
||||
And also run the linter on your code:
|
||||
|
||||
```sh
|
||||
stack build hlint
|
||||
stack exec hlint -- src tests
|
||||
```
|
||||
|
||||
Build the documentation and check if you get any warnings:
|
||||
|
||||
```sh
|
||||
stack haddock
|
||||
```
|
||||
|
||||
Validate that literate Haskell (tutorials) files compile without any warnings:
|
||||
|
||||
```sh
|
||||
stack ghc -- -Wall -fno-code docs/tutorial/*.lhs
|
||||
```
|
2
LICENSE
2
LICENSE
|
@ -1,4 +1,4 @@
|
|||
Copyright 2019 Eugen Wissner, Germany
|
||||
Copyright 2019-2020 Eugen Wissner, Germany
|
||||
Copyright 2015-2017 J. Daniel Navarro
|
||||
|
||||
All rights reserved.
|
||||
|
|
|
@ -24,11 +24,18 @@ For the list of currently missing features see issues marked as
|
|||
## Documentation
|
||||
|
||||
API documentation is available through
|
||||
[hackage](https://hackage.haskell.org/package/graphql).
|
||||
[Hackage](https://hackage.haskell.org/package/graphql).
|
||||
|
||||
You'll also find a small tutorial with some examples under
|
||||
[docs/tutorial](https://github.com/caraus-ecms/graphql/tree/master/docs/tutorial).
|
||||
|
||||
## Further information
|
||||
|
||||
- [Contributing guidelines](CONTRIBUTING.md).
|
||||
- [Changelog](CHANGELOG.md) – this one contains the most recent changes;
|
||||
individual changelogs for specific versions can be found on
|
||||
[Hackage](https://hackage.haskell.org/package/graphql).
|
||||
|
||||
## Contact
|
||||
|
||||
Suggestions, contributions and bug reports are welcome.
|
||||
|
|
|
@ -12,20 +12,19 @@ We have written a small tutorial to help you (and ourselves) understand the grap
|
|||
Since this file is a literate haskell file, we start by importing some dependencies.
|
||||
|
||||
> {-# LANGUAGE OverloadedStrings #-}
|
||||
> {-# LANGUAGE LambdaCase #-}
|
||||
> module Main where
|
||||
>
|
||||
> import Control.Monad.IO.Class (liftIO)
|
||||
> import Control.Monad.Trans.Except (throwE)
|
||||
> import Data.Aeson (encode)
|
||||
> import Data.ByteString.Lazy.Char8 (putStrLn)
|
||||
> import Data.HashMap.Strict (HashMap)
|
||||
> import qualified Data.HashMap.Strict as HashMap
|
||||
> import Data.List.NonEmpty (NonEmpty(..))
|
||||
> import Data.Text (Text)
|
||||
> import Data.Time (getCurrentTime)
|
||||
>
|
||||
> import Language.GraphQL
|
||||
> import qualified Language.GraphQL.Schema as Schema
|
||||
> import Language.GraphQL.Trans (ActionT(..))
|
||||
>
|
||||
> import Prelude hiding (putStrLn)
|
||||
|
||||
|
@ -36,8 +35,8 @@ example from [graphql.js](https://github.com/graphql/graphql-js).
|
|||
|
||||
First we build a GraphQL schema.
|
||||
|
||||
> schema1 :: NonEmpty (Schema.Resolver IO)
|
||||
> schema1 = hello :| []
|
||||
> schema1 :: HashMap Text (NonEmpty (Schema.Resolver IO))
|
||||
> schema1 = HashMap.singleton "Query" $ hello :| []
|
||||
>
|
||||
> hello :: Schema.Resolver IO
|
||||
> hello = Schema.scalar "hello" (return ("it's me" :: Text))
|
||||
|
@ -66,14 +65,13 @@ returning
|
|||
|
||||
For this example, we're going to be using time.
|
||||
|
||||
> schema2 :: NonEmpty (Schema.Resolver IO)
|
||||
> schema2 = time :| []
|
||||
> schema2 :: HashMap Text (NonEmpty (Schema.Resolver IO))
|
||||
> schema2 = HashMap.singleton "Query" $ time :| []
|
||||
>
|
||||
> time :: Schema.Resolver IO
|
||||
> time = Schema.scalarA "time" $ \case
|
||||
> [] -> do t <- liftIO getCurrentTime
|
||||
> return $ show t
|
||||
> _ -> ActionT $ throwE "Invalid arguments."
|
||||
> time = Schema.scalar "time" $ do
|
||||
> t <- liftIO getCurrentTime
|
||||
> return $ show t
|
||||
|
||||
This defines a simple schema with one type and one field,
|
||||
which resolves to the current time.
|
||||
|
@ -126,8 +124,8 @@ This will fail
|
|||
|
||||
Now that we have two resolvers, we can define a schema which uses them both.
|
||||
|
||||
> schema3 :: NonEmpty (Schema.Resolver IO)
|
||||
> schema3 = hello :| [time]
|
||||
> schema3 :: HashMap Text (NonEmpty (Schema.Resolver IO))
|
||||
> schema3 = HashMap.singleton "Query" $ hello :| [time]
|
||||
>
|
||||
> query3 :: Text
|
||||
> query3 = "query timeAndHello { time hello }"
|
||||
|
|
|
@ -1,5 +1,5 @@
|
|||
name: graphql
|
||||
version: 0.6.1.0
|
||||
version: 0.7.0.0
|
||||
synopsis: Haskell GraphQL implementation
|
||||
description:
|
||||
This package provides a rudimentary parser for the
|
||||
|
@ -8,7 +8,7 @@ maintainer: belka@caraus.de
|
|||
github: caraus-ecms/graphql
|
||||
category: Language
|
||||
copyright:
|
||||
- (c) 2019 Eugen Wissner
|
||||
- (c) 2019-2020 Eugen Wissner
|
||||
- (c) 2015-2017 J. Daniel Navarro
|
||||
author:
|
||||
- Danny Navarro <j@dannynavarro.net>
|
||||
|
@ -30,6 +30,7 @@ dependencies:
|
|||
- base >= 4.7 && < 5
|
||||
- containers
|
||||
- megaparsec
|
||||
- parser-combinators
|
||||
- text
|
||||
- transformers
|
||||
- unordered-containers
|
||||
|
@ -53,4 +54,5 @@ tests:
|
|||
- hspec
|
||||
- hspec-expectations
|
||||
- hspec-megaparsec
|
||||
- QuickCheck
|
||||
- raw-strings-qq
|
||||
|
|
|
@ -8,7 +8,12 @@ setup() {
|
|||
then
|
||||
curl -L https://get.haskellstack.org/stable/linux-x86_64.tar.gz | tar xz --wildcards --strip-components=1 -C $SEMAPHORE_CACHE_DIR '*/stack'
|
||||
fi
|
||||
if [ -e "$SEMAPHORE_CACHE_DIR/graphql.cabal" ]
|
||||
then
|
||||
cp -a $SEMAPHORE_CACHE_DIR/graphql.cabal graphql.cabal
|
||||
fi
|
||||
$STACK --no-terminal setup
|
||||
cp -a graphql.cabal $SEMAPHORE_CACHE_DIR/graphql.cabal
|
||||
}
|
||||
|
||||
setup_test() {
|
||||
|
|
|
@ -4,10 +4,10 @@ module Language.GraphQL
|
|||
, graphqlSubs
|
||||
) where
|
||||
|
||||
import Control.Monad.IO.Class (MonadIO)
|
||||
import qualified Data.Aeson as Aeson
|
||||
import Data.List.NonEmpty (NonEmpty)
|
||||
import qualified Data.Text as T
|
||||
import Data.HashMap.Strict (HashMap)
|
||||
import Data.Text (Text)
|
||||
import Language.GraphQL.Error
|
||||
import Language.GraphQL.Execute
|
||||
import Language.GraphQL.AST.Parser
|
||||
|
@ -16,19 +16,19 @@ import Text.Megaparsec (parse)
|
|||
|
||||
-- | If the text parses correctly as a @GraphQL@ query the query is
|
||||
-- executed using the given 'Schema.Resolver's.
|
||||
graphql :: MonadIO m
|
||||
=> NonEmpty (Schema.Resolver m) -- ^ Resolvers.
|
||||
-> T.Text -- ^ Text representing a @GraphQL@ request document.
|
||||
graphql :: Monad m
|
||||
=> HashMap Text (NonEmpty (Schema.Resolver m)) -- ^ Resolvers.
|
||||
-> Text -- ^ Text representing a @GraphQL@ request document.
|
||||
-> m Aeson.Value -- ^ Response.
|
||||
graphql = flip graphqlSubs $ const Nothing
|
||||
graphql = flip graphqlSubs mempty
|
||||
|
||||
-- | 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.Resolver's.
|
||||
graphqlSubs :: MonadIO m
|
||||
=> NonEmpty (Schema.Resolver m) -- ^ Resolvers.
|
||||
graphqlSubs :: Monad m
|
||||
=> HashMap Text (NonEmpty (Schema.Resolver m)) -- ^ Resolvers.
|
||||
-> Schema.Subs -- ^ Variable substitution function.
|
||||
-> T.Text -- ^ Text representing a @GraphQL@ request document.
|
||||
-> Text -- ^ Text representing a @GraphQL@ request document.
|
||||
-> m Aeson.Value -- ^ Response.
|
||||
graphqlSubs schema f
|
||||
= either parseError (execute schema f)
|
||||
|
|
|
@ -1,185 +1,6 @@
|
|||
-- | This module defines an abstract syntax tree for the @GraphQL@ language based on
|
||||
-- <https://facebook.github.io/graphql/ Facebook's GraphQL Specification>.
|
||||
--
|
||||
-- Target AST for Parser.
|
||||
-- | Target AST for Parser.
|
||||
module Language.GraphQL.AST
|
||||
( Alias
|
||||
, Argument(..)
|
||||
, Definition(..)
|
||||
, Directive(..)
|
||||
, Document
|
||||
, Field(..)
|
||||
, FragmentDefinition(..)
|
||||
, FragmentSpread(..)
|
||||
, InlineFragment(..)
|
||||
, Name
|
||||
, NonNullType(..)
|
||||
, ObjectField(..)
|
||||
, OperationDefinition(..)
|
||||
, OperationType(..)
|
||||
, Selection(..)
|
||||
, SelectionSet
|
||||
, SelectionSetOpt
|
||||
, Type(..)
|
||||
, TypeCondition
|
||||
, Value(..)
|
||||
, VariableDefinition(..)
|
||||
( module Language.GraphQL.AST.Document
|
||||
) where
|
||||
|
||||
import Data.Int (Int32)
|
||||
import Data.List.NonEmpty (NonEmpty)
|
||||
import Data.Text (Text)
|
||||
|
||||
-- * Document
|
||||
|
||||
-- | GraphQL document.
|
||||
type Document = NonEmpty Definition
|
||||
|
||||
-- | Name
|
||||
type Name = Text
|
||||
|
||||
-- | Directive.
|
||||
data Directive = Directive Name [Argument] deriving (Eq, Show)
|
||||
|
||||
-- * Operations
|
||||
|
||||
-- | Top-level definition of a document, either an operation or a fragment.
|
||||
data Definition
|
||||
= DefinitionOperation OperationDefinition
|
||||
| DefinitionFragment FragmentDefinition
|
||||
deriving (Eq, Show)
|
||||
|
||||
-- | Operation definition.
|
||||
data OperationDefinition
|
||||
= OperationSelectionSet SelectionSet
|
||||
| OperationDefinition OperationType
|
||||
(Maybe Name)
|
||||
[VariableDefinition]
|
||||
[Directive]
|
||||
SelectionSet
|
||||
deriving (Eq, Show)
|
||||
|
||||
-- | GraphQL has 3 operation types: queries, mutations and subscribtions.
|
||||
--
|
||||
-- Currently only queries and mutations are supported.
|
||||
data OperationType = Query | Mutation deriving (Eq, Show)
|
||||
|
||||
-- * Selections
|
||||
|
||||
-- | "Top-level" selection, selection on an operation or fragment.
|
||||
type SelectionSet = NonEmpty Selection
|
||||
|
||||
-- | Field selection.
|
||||
type SelectionSetOpt = [Selection]
|
||||
|
||||
-- | Single selection element.
|
||||
data Selection
|
||||
= SelectionField Field
|
||||
| SelectionFragmentSpread FragmentSpread
|
||||
| SelectionInlineFragment InlineFragment
|
||||
deriving (Eq, Show)
|
||||
|
||||
-- * Field
|
||||
|
||||
-- | Single GraphQL field.
|
||||
--
|
||||
-- The only required property of a field is its name. Optionally it can also
|
||||
-- have an alias, arguments or a list of subfields.
|
||||
--
|
||||
-- Given the following query:
|
||||
--
|
||||
-- @
|
||||
-- {
|
||||
-- zuck: user(id: 4) {
|
||||
-- id
|
||||
-- name
|
||||
-- }
|
||||
-- }
|
||||
-- @
|
||||
--
|
||||
-- * "user", "id" and "name" are field names.
|
||||
-- * "user" has two subfields, "id" and "name".
|
||||
-- * "zuck" is an alias for "user". "id" and "name" have no aliases.
|
||||
-- * "id: 4" is an argument for "user". "id" and "name" don't have any
|
||||
-- arguments.
|
||||
data Field
|
||||
= Field (Maybe Alias) Name [Argument] [Directive] SelectionSetOpt
|
||||
deriving (Eq, Show)
|
||||
|
||||
-- | Alternative field name.
|
||||
--
|
||||
-- @
|
||||
-- {
|
||||
-- smallPic: profilePic(size: 64)
|
||||
-- bigPic: profilePic(size: 1024)
|
||||
-- }
|
||||
-- @
|
||||
--
|
||||
-- Here "smallPic" and "bigPic" are aliases for the same field, "profilePic",
|
||||
-- used to distinquish between profile pictures with different arguments
|
||||
-- (sizes).
|
||||
type Alias = Name
|
||||
|
||||
-- | Single argument.
|
||||
--
|
||||
-- @
|
||||
-- {
|
||||
-- user(id: 4) {
|
||||
-- name
|
||||
-- }
|
||||
-- }
|
||||
-- @
|
||||
--
|
||||
-- Here "id" is an argument for the field "user" and its value is 4.
|
||||
data Argument = Argument Name Value deriving (Eq,Show)
|
||||
|
||||
-- * Fragments
|
||||
|
||||
-- | Fragment spread.
|
||||
data FragmentSpread = FragmentSpread Name [Directive] deriving (Eq, Show)
|
||||
|
||||
-- | Inline fragment.
|
||||
data InlineFragment = InlineFragment (Maybe TypeCondition) [Directive] SelectionSet
|
||||
deriving (Eq, Show)
|
||||
|
||||
-- | Fragment definition.
|
||||
data FragmentDefinition
|
||||
= FragmentDefinition Name TypeCondition [Directive] SelectionSet
|
||||
deriving (Eq, Show)
|
||||
|
||||
-- * Inputs
|
||||
|
||||
-- | Input value.
|
||||
data Value = Variable Name
|
||||
| Int Int32
|
||||
| Float Double
|
||||
| String Text
|
||||
| Boolean Bool
|
||||
| Null
|
||||
| Enum Name
|
||||
| List [Value]
|
||||
| Object [ObjectField]
|
||||
deriving (Eq, Show)
|
||||
|
||||
-- | Key-value pair.
|
||||
--
|
||||
-- A list of 'ObjectField's represents a GraphQL object type.
|
||||
data ObjectField = ObjectField Name Value deriving (Eq, Show)
|
||||
|
||||
-- | Variable definition.
|
||||
data VariableDefinition = VariableDefinition Name Type (Maybe Value)
|
||||
deriving (Eq, Show)
|
||||
|
||||
-- | Type condition.
|
||||
type TypeCondition = Name
|
||||
|
||||
-- | Type representation.
|
||||
data Type = TypeNamed Name
|
||||
| TypeList Type
|
||||
| TypeNonNull NonNullType
|
||||
deriving (Eq, Show)
|
||||
|
||||
-- | Helper type to represent Non-Null types and lists of such types.
|
||||
data NonNullType = NonNullTypeNamed Name
|
||||
| NonNullTypeList Type
|
||||
deriving (Eq, Show)
|
||||
import Language.GraphQL.AST.Document
|
||||
|
|
|
@ -1,7 +1,6 @@
|
|||
-- | This is the AST meant to be executed.
|
||||
module Language.GraphQL.AST.Core
|
||||
( Alias
|
||||
, Argument(..)
|
||||
, Arguments(..)
|
||||
, Directive(..)
|
||||
, Document
|
||||
|
@ -35,16 +34,19 @@ data Operation
|
|||
|
||||
-- | Single GraphQL field.
|
||||
data Field
|
||||
= Field (Maybe Alias) Name [Argument] (Seq Selection)
|
||||
= Field (Maybe Alias) Name Arguments (Seq Selection)
|
||||
deriving (Eq, Show)
|
||||
|
||||
-- | Single argument.
|
||||
data Argument = Argument Name Value deriving (Eq, Show)
|
||||
|
||||
-- | Argument list.
|
||||
newtype Arguments = Arguments (HashMap Name Value)
|
||||
deriving (Eq, Show)
|
||||
|
||||
instance Semigroup Arguments where
|
||||
(Arguments x) <> (Arguments y) = Arguments $ x <> y
|
||||
|
||||
instance Monoid Arguments where
|
||||
mempty = Arguments mempty
|
||||
|
||||
-- | Directive.
|
||||
data Directive = Directive Name Arguments
|
||||
deriving (Eq, Show)
|
||||
|
|
|
@ -0,0 +1,41 @@
|
|||
-- | 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(..)
|
||||
, ExecutableDirectiveLocation(..)
|
||||
, TypeSystemDirectiveLocation(..)
|
||||
) where
|
||||
|
||||
-- | All directives can be splitted in two groups: directives used to annotate
|
||||
-- various parts of executable definitions and the ones used in the schema
|
||||
-- definition.
|
||||
data DirectiveLocation
|
||||
= ExecutableDirectiveLocation ExecutableDirectiveLocation
|
||||
| TypeSystemDirectiveLocation TypeSystemDirectiveLocation
|
||||
deriving (Eq, Show)
|
||||
|
||||
-- | Where directives can appear in an executable definition, like a query.
|
||||
data ExecutableDirectiveLocation
|
||||
= Query
|
||||
| Mutation
|
||||
| Subscription
|
||||
| Field
|
||||
| FragmentDefinition
|
||||
| FragmentSpread
|
||||
| InlineFragment
|
||||
deriving (Eq, Show)
|
||||
|
||||
-- | Where directives can appear in a type system definition.
|
||||
data TypeSystemDirectiveLocation
|
||||
= Schema
|
||||
| Scalar
|
||||
| Object
|
||||
| FieldDefinition
|
||||
| ArgumentDefinition
|
||||
| Interface
|
||||
| Union
|
||||
| Enum
|
||||
| EnumValue
|
||||
| InputObject
|
||||
| InputFieldDefinition
|
||||
deriving (Eq, Show)
|
|
@ -0,0 +1,486 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
-- | This module defines an abstract syntax tree for the @GraphQL@ language. It
|
||||
-- follows closely the structure given in the specification. Please refer to
|
||||
-- <https://facebook.github.io/graphql/ Facebook's GraphQL Specification>.
|
||||
-- for more information.
|
||||
module Language.GraphQL.AST.Document
|
||||
( Alias
|
||||
, Argument(..)
|
||||
, ArgumentsDefinition(..)
|
||||
, Definition(..)
|
||||
, Description(..)
|
||||
, Directive(..)
|
||||
, Document
|
||||
, EnumValueDefinition(..)
|
||||
, ExecutableDefinition(..)
|
||||
, FieldDefinition(..)
|
||||
, FragmentDefinition(..)
|
||||
, ImplementsInterfaces(..)
|
||||
, InputValueDefinition(..)
|
||||
, Name
|
||||
, NamedType
|
||||
, NonNullType(..)
|
||||
, ObjectField(..)
|
||||
, OperationDefinition(..)
|
||||
, OperationType(..)
|
||||
, OperationTypeDefinition(..)
|
||||
, SchemaExtension(..)
|
||||
, Selection(..)
|
||||
, SelectionSet
|
||||
, SelectionSetOpt
|
||||
, Type(..)
|
||||
, TypeCondition
|
||||
, TypeDefinition(..)
|
||||
, TypeExtension(..)
|
||||
, TypeSystemDefinition(..)
|
||||
, TypeSystemExtension(..)
|
||||
, UnionMemberTypes(..)
|
||||
, Value(..)
|
||||
, VariableDefinition(..)
|
||||
) where
|
||||
|
||||
import Data.Foldable (toList)
|
||||
import Data.Int (Int32)
|
||||
import Data.List.NonEmpty (NonEmpty)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as Text
|
||||
import Language.GraphQL.AST.DirectiveLocation
|
||||
|
||||
-- * Language
|
||||
|
||||
-- ** Source Text
|
||||
|
||||
-- | Name.
|
||||
type Name = Text
|
||||
|
||||
-- ** Document
|
||||
|
||||
-- | GraphQL document.
|
||||
type Document = NonEmpty Definition
|
||||
|
||||
-- | All kinds of definitions that can occur in a GraphQL document.
|
||||
data Definition
|
||||
= ExecutableDefinition ExecutableDefinition
|
||||
| TypeSystemDefinition TypeSystemDefinition
|
||||
| TypeSystemExtension TypeSystemExtension
|
||||
deriving (Eq, Show)
|
||||
|
||||
-- | Top-level definition of a document, either an operation or a fragment.
|
||||
data ExecutableDefinition
|
||||
= DefinitionOperation OperationDefinition
|
||||
| DefinitionFragment FragmentDefinition
|
||||
deriving (Eq, Show)
|
||||
|
||||
-- ** Operations
|
||||
|
||||
-- | Operation definition.
|
||||
data OperationDefinition
|
||||
= SelectionSet SelectionSet
|
||||
| OperationDefinition
|
||||
OperationType
|
||||
(Maybe Name)
|
||||
[VariableDefinition]
|
||||
[Directive]
|
||||
SelectionSet
|
||||
deriving (Eq, Show)
|
||||
|
||||
-- | GraphQL has 3 operation types:
|
||||
--
|
||||
-- * query - a read-only fetch.
|
||||
-- * mutation - a write operation followed by a fetch.
|
||||
-- * subscription - a long-lived request that fetches data in response to
|
||||
-- source events.
|
||||
--
|
||||
-- Currently only queries and mutations are supported.
|
||||
data OperationType = Query | Mutation deriving (Eq, Show)
|
||||
|
||||
-- ** Selection Sets
|
||||
|
||||
-- | "Top-level" selection, selection on an operation or fragment.
|
||||
type SelectionSet = NonEmpty Selection
|
||||
|
||||
-- | Field selection.
|
||||
type SelectionSetOpt = [Selection]
|
||||
|
||||
-- | Selection is a single entry in a selection set. It can be a single field,
|
||||
-- fragment spread or inline fragment.
|
||||
--
|
||||
-- The only required property of a field is its name. Optionally it can also
|
||||
-- have an alias, arguments, directives and a list of subfields.
|
||||
--
|
||||
-- In the following query "user" is a field with two subfields, "id" and "name":
|
||||
--
|
||||
-- @
|
||||
-- {
|
||||
-- user {
|
||||
-- id
|
||||
-- name
|
||||
-- }
|
||||
-- }
|
||||
-- @
|
||||
--
|
||||
-- A fragment spread refers to a fragment defined outside the operation and is
|
||||
-- expanded at the execution time.
|
||||
--
|
||||
-- @
|
||||
-- {
|
||||
-- user {
|
||||
-- ...userFragment
|
||||
-- }
|
||||
-- }
|
||||
--
|
||||
-- fragment userFragment on UserType {
|
||||
-- id
|
||||
-- name
|
||||
-- }
|
||||
-- @
|
||||
--
|
||||
-- Inline fragments are similar but they don't have any name and the type
|
||||
-- condition ("on UserType") is optional.
|
||||
--
|
||||
-- @
|
||||
-- {
|
||||
-- user {
|
||||
-- ... on UserType {
|
||||
-- id
|
||||
-- name
|
||||
-- }
|
||||
-- }
|
||||
-- @
|
||||
data Selection
|
||||
= Field (Maybe Alias) Name [Argument] [Directive] SelectionSetOpt
|
||||
| FragmentSpread Name [Directive]
|
||||
| InlineFragment (Maybe TypeCondition) [Directive] SelectionSet
|
||||
deriving (Eq, Show)
|
||||
|
||||
-- ** Arguments
|
||||
|
||||
-- | Single argument.
|
||||
--
|
||||
-- @
|
||||
-- {
|
||||
-- user(id: 4) {
|
||||
-- name
|
||||
-- }
|
||||
-- }
|
||||
-- @
|
||||
--
|
||||
-- Here "id" is an argument for the field "user" and its value is 4.
|
||||
data Argument = Argument Name Value deriving (Eq,Show)
|
||||
|
||||
-- ** Field Alias
|
||||
|
||||
-- | Alternative field name.
|
||||
--
|
||||
-- @
|
||||
-- {
|
||||
-- smallPic: profilePic(size: 64)
|
||||
-- bigPic: profilePic(size: 1024)
|
||||
-- }
|
||||
-- @
|
||||
--
|
||||
-- Here "smallPic" and "bigPic" are aliases for the same field, "profilePic",
|
||||
-- used to distinquish between profile pictures with different arguments
|
||||
-- (sizes).
|
||||
type Alias = Name
|
||||
|
||||
-- ** Fragments
|
||||
|
||||
-- | Fragment definition.
|
||||
data FragmentDefinition
|
||||
= FragmentDefinition Name TypeCondition [Directive] SelectionSet
|
||||
deriving (Eq, Show)
|
||||
|
||||
-- | Type condition.
|
||||
type TypeCondition = Name
|
||||
|
||||
-- ** Input Values
|
||||
|
||||
-- | Input value.
|
||||
data Value
|
||||
= Variable Name
|
||||
| Int Int32
|
||||
| Float Double
|
||||
| String Text
|
||||
| Boolean Bool
|
||||
| Null
|
||||
| Enum Name
|
||||
| List [Value]
|
||||
| Object [ObjectField]
|
||||
deriving (Eq, Show)
|
||||
|
||||
-- | Key-value pair.
|
||||
--
|
||||
-- A list of 'ObjectField's represents a GraphQL object type.
|
||||
data ObjectField = ObjectField Name Value deriving (Eq, Show)
|
||||
|
||||
-- ** Variables
|
||||
|
||||
-- | Variable definition.
|
||||
data VariableDefinition = VariableDefinition Name Type (Maybe Value)
|
||||
deriving (Eq, Show)
|
||||
|
||||
-- ** Type References
|
||||
|
||||
-- | Type representation.
|
||||
data Type
|
||||
= TypeNamed Name
|
||||
| TypeList Type
|
||||
| TypeNonNull NonNullType
|
||||
deriving (Eq, Show)
|
||||
|
||||
-- | Represents type names.
|
||||
type NamedType = Name
|
||||
|
||||
-- | Helper type to represent Non-Null types and lists of such types.
|
||||
data NonNullType
|
||||
= NonNullTypeNamed Name
|
||||
| NonNullTypeList Type
|
||||
deriving (Eq, Show)
|
||||
|
||||
-- ** Directives
|
||||
|
||||
-- | Directive.
|
||||
--
|
||||
-- Directives begin with "@", can accept arguments, and can be applied to the
|
||||
-- most GraphQL elements, providing additional information.
|
||||
data Directive = Directive Name [Argument] deriving (Eq, Show)
|
||||
|
||||
-- * Type System
|
||||
|
||||
-- | Type system can define a schema, a type or a directive.
|
||||
--
|
||||
-- @
|
||||
-- schema {
|
||||
-- query: Query
|
||||
-- }
|
||||
--
|
||||
-- directive @example on FIELD_DEFINITION
|
||||
--
|
||||
-- type Query {
|
||||
-- field: String @example
|
||||
-- }
|
||||
-- @
|
||||
--
|
||||
-- This example defines a custom directive "@example", which is applied to a
|
||||
-- field definition of the type definition "Query". On the top the schema
|
||||
-- is defined by taking advantage of the type "Query".
|
||||
data TypeSystemDefinition
|
||||
= SchemaDefinition [Directive] (NonEmpty OperationTypeDefinition)
|
||||
| TypeDefinition TypeDefinition
|
||||
| DirectiveDefinition
|
||||
Description Name ArgumentsDefinition (NonEmpty DirectiveLocation)
|
||||
deriving (Eq, Show)
|
||||
|
||||
-- ** Type System Extensions
|
||||
|
||||
-- | Extension for a type system definition. Only schema and type definitions
|
||||
-- can be extended.
|
||||
data TypeSystemExtension
|
||||
= SchemaExtension SchemaExtension
|
||||
| TypeExtension TypeExtension
|
||||
deriving (Eq, Show)
|
||||
|
||||
-- ** Schema
|
||||
|
||||
-- | Root operation type definition.
|
||||
--
|
||||
-- Defining root operation types is not required since they have defaults. So
|
||||
-- the default query root type is "Query", and the default mutation root type
|
||||
-- is "Mutation". But these defaults can be changed for a specific schema. In
|
||||
-- the following code the query root type is changed to "MyQueryRootType", and
|
||||
-- the mutation root type to "MyMutationRootType":
|
||||
--
|
||||
-- @
|
||||
-- schema {
|
||||
-- query: MyQueryRootType
|
||||
-- mutation: MyMutationRootType
|
||||
-- }
|
||||
-- @
|
||||
data OperationTypeDefinition
|
||||
= OperationTypeDefinition OperationType NamedType
|
||||
deriving (Eq, Show)
|
||||
|
||||
-- | Extension of the schema definition by further operations or directives.
|
||||
data SchemaExtension
|
||||
= SchemaOperationExtension [Directive] (NonEmpty OperationTypeDefinition)
|
||||
| SchemaDirectivesExtension (NonEmpty Directive)
|
||||
deriving (Eq, Show)
|
||||
|
||||
-- ** Descriptions
|
||||
|
||||
-- | GraphQL has built-in capability to document service APIs. Documentation
|
||||
-- is a GraphQL string that precedes a particular definition and contains
|
||||
-- Markdown. Any GraphQL definition can be documented this way.
|
||||
--
|
||||
-- @
|
||||
-- """
|
||||
-- Supported languages.
|
||||
-- """
|
||||
-- enum Language {
|
||||
-- "English"
|
||||
-- EN
|
||||
--
|
||||
-- "Russian"
|
||||
-- RU
|
||||
-- }
|
||||
-- @
|
||||
newtype Description = Description (Maybe Text)
|
||||
deriving (Eq, Show)
|
||||
|
||||
-- ** Types
|
||||
|
||||
-- | Type definitions describe various user-defined types.
|
||||
data TypeDefinition
|
||||
= ScalarTypeDefinition Description Name [Directive]
|
||||
| ObjectTypeDefinition
|
||||
Description
|
||||
Name
|
||||
(ImplementsInterfaces [])
|
||||
[Directive]
|
||||
[FieldDefinition]
|
||||
| InterfaceTypeDefinition Description Name [Directive] [FieldDefinition]
|
||||
| UnionTypeDefinition Description Name [Directive] (UnionMemberTypes [])
|
||||
| EnumTypeDefinition Description Name [Directive] [EnumValueDefinition]
|
||||
| InputObjectTypeDefinition
|
||||
Description Name [Directive] [InputValueDefinition]
|
||||
deriving (Eq, Show)
|
||||
|
||||
-- | Extensions for custom, already defined types.
|
||||
data TypeExtension
|
||||
= ScalarTypeExtension Name (NonEmpty Directive)
|
||||
| ObjectTypeFieldsDefinitionExtension
|
||||
Name (ImplementsInterfaces []) [Directive] (NonEmpty FieldDefinition)
|
||||
| ObjectTypeDirectivesExtension
|
||||
Name (ImplementsInterfaces []) (NonEmpty Directive)
|
||||
| ObjectTypeImplementsInterfacesExtension
|
||||
Name (ImplementsInterfaces NonEmpty)
|
||||
| InterfaceTypeFieldsDefinitionExtension
|
||||
Name [Directive] (NonEmpty FieldDefinition)
|
||||
| InterfaceTypeDirectivesExtension Name (NonEmpty Directive)
|
||||
| UnionTypeUnionMemberTypesExtension
|
||||
Name [Directive] (UnionMemberTypes NonEmpty)
|
||||
| UnionTypeDirectivesExtension Name (NonEmpty Directive)
|
||||
| EnumTypeEnumValuesDefinitionExtension
|
||||
Name [Directive] (NonEmpty EnumValueDefinition)
|
||||
| EnumTypeDirectivesExtension Name (NonEmpty Directive)
|
||||
| InputObjectTypeInputFieldsDefinitionExtension
|
||||
Name [Directive] (NonEmpty InputValueDefinition)
|
||||
| InputObjectTypeDirectivesExtension Name (NonEmpty Directive)
|
||||
deriving (Eq, Show)
|
||||
|
||||
-- ** Objects
|
||||
|
||||
-- | Defines a list of interfaces implemented by the given object type.
|
||||
--
|
||||
-- @
|
||||
-- type Business implements NamedEntity & ValuedEntity {
|
||||
-- name: String
|
||||
-- }
|
||||
-- @
|
||||
--
|
||||
-- Here the object type "Business" implements two interfaces: "NamedEntity" and
|
||||
-- "ValuedEntity".
|
||||
newtype ImplementsInterfaces t = ImplementsInterfaces (t NamedType)
|
||||
|
||||
instance Foldable t => Eq (ImplementsInterfaces t) where
|
||||
(ImplementsInterfaces xs) == (ImplementsInterfaces ys)
|
||||
= toList xs == toList ys
|
||||
|
||||
instance Foldable t => Show (ImplementsInterfaces t) where
|
||||
show (ImplementsInterfaces interfaces) = Text.unpack
|
||||
$ Text.append "implements"
|
||||
$ Text.intercalate " & "
|
||||
$ toList interfaces
|
||||
|
||||
-- | Definition of a single field in a type.
|
||||
--
|
||||
-- @
|
||||
-- type Person {
|
||||
-- name: String
|
||||
-- picture(width: Int, height: Int): Url
|
||||
-- }
|
||||
-- @
|
||||
--
|
||||
-- "name" and "picture", including their arguments and types, are field
|
||||
-- definitions.
|
||||
data FieldDefinition
|
||||
= FieldDefinition Description Name ArgumentsDefinition Type [Directive]
|
||||
deriving (Eq, Show)
|
||||
|
||||
-- | A list of values passed to a field.
|
||||
--
|
||||
-- @
|
||||
-- type Person {
|
||||
-- name: String
|
||||
-- picture(width: Int, height: Int): Url
|
||||
-- }
|
||||
-- @
|
||||
--
|
||||
-- "Person" has two fields, "name" and "picture". "name" doesn't have any
|
||||
-- arguments, so 'ArgumentsDefinition' contains an empty list. "picture"
|
||||
-- contains definitions for 2 arguments: "width" and "height".
|
||||
newtype ArgumentsDefinition = ArgumentsDefinition [InputValueDefinition]
|
||||
deriving (Eq, Show)
|
||||
|
||||
instance Semigroup ArgumentsDefinition where
|
||||
(ArgumentsDefinition xs) <> (ArgumentsDefinition ys) =
|
||||
ArgumentsDefinition $ xs <> ys
|
||||
|
||||
instance Monoid ArgumentsDefinition where
|
||||
mempty = ArgumentsDefinition []
|
||||
|
||||
-- | Defines an input value.
|
||||
--
|
||||
-- * Input values can define field arguments, see 'ArgumentsDefinition'.
|
||||
-- * They can also be used as field definitions in an input type.
|
||||
--
|
||||
-- @
|
||||
-- input Point2D {
|
||||
-- x: Float
|
||||
-- y: Float
|
||||
-- }
|
||||
-- @
|
||||
--
|
||||
-- The input type "Point2D" contains two value definitions: "x" and "y".
|
||||
data InputValueDefinition
|
||||
= InputValueDefinition Description Name Type (Maybe Value) [Directive]
|
||||
deriving (Eq, Show)
|
||||
|
||||
-- ** Unions
|
||||
|
||||
-- | List of types forming a union.
|
||||
--
|
||||
-- @
|
||||
-- union SearchResult = Person | Photo
|
||||
-- @
|
||||
--
|
||||
-- "Person" and "Photo" are member types of the union "SearchResult".
|
||||
newtype UnionMemberTypes t = UnionMemberTypes (t NamedType)
|
||||
|
||||
instance Foldable t => Eq (UnionMemberTypes t) where
|
||||
(UnionMemberTypes xs) == (UnionMemberTypes ys) = toList xs == toList ys
|
||||
|
||||
instance Foldable t => Show (UnionMemberTypes t) where
|
||||
show (UnionMemberTypes memberTypes) = Text.unpack
|
||||
$ Text.intercalate " | "
|
||||
$ toList memberTypes
|
||||
|
||||
-- ** Enums
|
||||
|
||||
-- | Single value in an enum definition.
|
||||
--
|
||||
-- @
|
||||
-- enum Direction {
|
||||
-- NORTH
|
||||
-- EAST
|
||||
-- SOUTH
|
||||
-- WEST
|
||||
-- }
|
||||
-- @
|
||||
--
|
||||
-- "NORTH, "EAST", "SOUTH", and "WEST" are value definitions of an enum type
|
||||
-- definition "Direction".
|
||||
data EnumValueDefinition = EnumValueDefinition Description Name [Directive]
|
||||
deriving (Eq, Show)
|
|
@ -15,7 +15,6 @@ module Language.GraphQL.AST.Encoder
|
|||
|
||||
import Data.Char (ord)
|
||||
import Data.Foldable (fold)
|
||||
import Data.Monoid ((<>))
|
||||
import qualified Data.List.NonEmpty as NonEmpty
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as Text
|
||||
|
@ -26,6 +25,7 @@ import qualified Data.Text.Lazy.Builder as Builder
|
|||
import Data.Text.Lazy.Builder.Int (decimal, hexadecimal)
|
||||
import Data.Text.Lazy.Builder.RealFloat (realFloat)
|
||||
import qualified Language.GraphQL.AST as Full
|
||||
import Language.GraphQL.AST.Document
|
||||
|
||||
-- | Instructs the encoder whether the GraphQL document should be minified or
|
||||
-- pretty printed.
|
||||
|
@ -43,16 +43,18 @@ pretty = Pretty 0
|
|||
minified :: Formatter
|
||||
minified = Minified
|
||||
|
||||
-- | Converts a 'Full.Document' into a string.
|
||||
document :: Formatter -> Full.Document -> Lazy.Text
|
||||
-- | Converts a Document' into a string.
|
||||
document :: Formatter -> Document -> Lazy.Text
|
||||
document formatter defs
|
||||
| Pretty _ <- formatter = Lazy.Text.intercalate "\n" encodeDocument
|
||||
| Minified <-formatter = Lazy.Text.snoc (mconcat encodeDocument) '\n'
|
||||
where
|
||||
encodeDocument = NonEmpty.toList $ definition formatter <$> defs
|
||||
encodeDocument = foldr executableDefinition [] defs
|
||||
executableDefinition (ExecutableDefinition x) acc = definition formatter x : acc
|
||||
executableDefinition _ acc = acc
|
||||
|
||||
-- | Converts a 'Full.Definition' into a string.
|
||||
definition :: Formatter -> Full.Definition -> Lazy.Text
|
||||
-- | Converts a t'Full.ExecutableDefinition' into a string.
|
||||
definition :: Formatter -> ExecutableDefinition -> Lazy.Text
|
||||
definition formatter x
|
||||
| Pretty _ <- formatter = Lazy.Text.snoc (encodeDefinition x) '\n'
|
||||
| Minified <- formatter = encodeDefinition x
|
||||
|
@ -62,14 +64,16 @@ definition formatter x
|
|||
encodeDefinition (Full.DefinitionFragment fragment)
|
||||
= fragmentDefinition formatter fragment
|
||||
|
||||
-- | Converts a 'Full.OperationDefinition into a string.
|
||||
operationDefinition :: Formatter -> Full.OperationDefinition -> Lazy.Text
|
||||
operationDefinition formatter (Full.OperationSelectionSet sels)
|
||||
operationDefinition formatter (Full.SelectionSet sels)
|
||||
= selectionSet formatter sels
|
||||
operationDefinition formatter (Full.OperationDefinition Full.Query name vars dirs sels)
|
||||
= "query " <> node formatter name vars dirs sels
|
||||
operationDefinition formatter (Full.OperationDefinition Full.Mutation name vars dirs sels)
|
||||
= "mutation " <> node formatter name vars dirs sels
|
||||
|
||||
-- | Converts a Full.Query or Full.Mutation into a string.
|
||||
node :: Formatter ->
|
||||
Maybe Full.Name ->
|
||||
[Full.VariableDefinition] ->
|
||||
|
@ -110,17 +114,21 @@ selectionSet formatter
|
|||
selectionSetOpt :: Formatter -> Full.SelectionSetOpt -> Lazy.Text
|
||||
selectionSetOpt formatter = bracesList formatter $ selection formatter
|
||||
|
||||
indentSymbol :: Lazy.Text
|
||||
indentSymbol = " "
|
||||
|
||||
indent :: (Integral a) => a -> Lazy.Text
|
||||
indent indentation = Lazy.Text.replicate (fromIntegral indentation) " "
|
||||
indent indentation = Lazy.Text.replicate (fromIntegral indentation) indentSymbol
|
||||
|
||||
selection :: Formatter -> Full.Selection -> Lazy.Text
|
||||
selection formatter = Lazy.Text.append indent' . encodeSelection
|
||||
where
|
||||
encodeSelection (Full.SelectionField field') = field incrementIndent field'
|
||||
encodeSelection (Full.SelectionInlineFragment fragment) =
|
||||
inlineFragment incrementIndent fragment
|
||||
encodeSelection (Full.SelectionFragmentSpread spread) =
|
||||
fragmentSpread incrementIndent spread
|
||||
encodeSelection (Full.Field alias name args directives' selections) =
|
||||
field incrementIndent alias name args directives' selections
|
||||
encodeSelection (Full.InlineFragment typeCondition directives' selections) =
|
||||
inlineFragment incrementIndent typeCondition directives' selections
|
||||
encodeSelection (Full.FragmentSpread name directives') =
|
||||
fragmentSpread incrementIndent name directives'
|
||||
incrementIndent
|
||||
| Pretty indentation <- formatter = Pretty $ indentation + 1
|
||||
| otherwise = Minified
|
||||
|
@ -131,8 +139,15 @@ selection formatter = Lazy.Text.append indent' . encodeSelection
|
|||
colon :: Formatter -> Lazy.Text
|
||||
colon formatter = eitherFormat formatter ": " ":"
|
||||
|
||||
field :: Formatter -> Full.Field -> Lazy.Text
|
||||
field formatter (Full.Field alias name args dirs set)
|
||||
-- | Converts Full.Field into a string
|
||||
field :: Formatter ->
|
||||
Maybe Full.Name ->
|
||||
Full.Name ->
|
||||
[Full.Argument] ->
|
||||
[Full.Directive] ->
|
||||
[Full.Selection] ->
|
||||
Lazy.Text
|
||||
field formatter alias name args dirs set
|
||||
= optempty prependAlias (fold alias)
|
||||
<> Lazy.Text.fromStrict name
|
||||
<> optempty (arguments formatter) args
|
||||
|
@ -154,13 +169,18 @@ argument formatter (Full.Argument name value')
|
|||
|
||||
-- * Fragments
|
||||
|
||||
fragmentSpread :: Formatter -> Full.FragmentSpread -> Lazy.Text
|
||||
fragmentSpread formatter (Full.FragmentSpread name ds)
|
||||
= "..." <> Lazy.Text.fromStrict name <> optempty (directives formatter) ds
|
||||
fragmentSpread :: Formatter -> Full.Name -> [Full.Directive] -> Lazy.Text
|
||||
fragmentSpread formatter name directives'
|
||||
= "..." <> Lazy.Text.fromStrict name
|
||||
<> optempty (directives formatter) directives'
|
||||
|
||||
inlineFragment :: Formatter -> Full.InlineFragment -> Lazy.Text
|
||||
inlineFragment formatter (Full.InlineFragment tc dirs sels)
|
||||
= "... on "
|
||||
inlineFragment ::
|
||||
Formatter ->
|
||||
Maybe Full.TypeCondition ->
|
||||
[Full.Directive] ->
|
||||
Full.SelectionSet ->
|
||||
Lazy.Text
|
||||
inlineFragment formatter tc dirs sels = "... on "
|
||||
<> Lazy.Text.fromStrict (fold tc)
|
||||
<> directives formatter dirs
|
||||
<> eitherFormat formatter " " mempty
|
||||
|
@ -191,7 +211,7 @@ value _ (Full.Variable x) = variable x
|
|||
value _ (Full.Int x) = Builder.toLazyText $ decimal x
|
||||
value _ (Full.Float x) = Builder.toLazyText $ realFloat x
|
||||
value _ (Full.Boolean x) = booleanValue x
|
||||
value _ Full.Null = mempty
|
||||
value _ Full.Null = "null"
|
||||
value formatter (Full.String string) = stringValue formatter string
|
||||
value _ (Full.Enum x) = Lazy.Text.fromStrict x
|
||||
value formatter (Full.List x) = listValue formatter x
|
||||
|
@ -201,26 +221,40 @@ booleanValue :: Bool -> Lazy.Text
|
|||
booleanValue True = "true"
|
||||
booleanValue False = "false"
|
||||
|
||||
quote :: Builder.Builder
|
||||
quote = Builder.singleton '\"'
|
||||
|
||||
oneLine :: Text -> Builder
|
||||
oneLine string = quote <> Text.foldr (mappend . escape) quote string
|
||||
|
||||
stringValue :: Formatter -> Text -> Lazy.Text
|
||||
stringValue Minified string = Builder.toLazyText
|
||||
$ quote <> Text.foldr (mappend . escape') quote string
|
||||
where
|
||||
quote = Builder.singleton '\"'
|
||||
escape' '\n' = Builder.fromString "\\n"
|
||||
escape' char = escape char
|
||||
stringValue (Pretty indentation) string = byStringType $ Text.lines string
|
||||
where
|
||||
byStringType [] = "\"\""
|
||||
byStringType [line] = Builder.toLazyText
|
||||
$ quote <> Text.foldr (mappend . escape) quote line
|
||||
byStringType lines' = "\"\"\"\n"
|
||||
<> Lazy.Text.unlines (transformLine <$> lines')
|
||||
<> indent indentation
|
||||
<> "\"\"\""
|
||||
transformLine = (indent (indentation + 1) <>)
|
||||
. Lazy.Text.fromStrict
|
||||
. Text.replace "\"\"\"" "\\\"\"\""
|
||||
quote = Builder.singleton '\"'
|
||||
$ quote <> Text.foldr (mappend . escape) quote string
|
||||
stringValue (Pretty indentation) string =
|
||||
if hasEscaped string
|
||||
then stringValue Minified string
|
||||
else Builder.toLazyText $ encoded lines'
|
||||
where
|
||||
isWhiteSpace char = char == ' ' || char == '\t'
|
||||
isNewline char = char == '\n' || char == '\r'
|
||||
hasEscaped = Text.any (not . isAllowed)
|
||||
isAllowed char =
|
||||
char == '\t' || isNewline char || (char >= '\x0020' && char /= '\x007F')
|
||||
|
||||
tripleQuote = Builder.fromText "\"\"\""
|
||||
start = tripleQuote <> Builder.singleton '\n'
|
||||
end = Builder.fromLazyText (indent indentation) <> tripleQuote
|
||||
|
||||
strip = Text.dropWhile isWhiteSpace . Text.dropWhileEnd isWhiteSpace
|
||||
lines' = map Builder.fromText $ Text.split isNewline (Text.replace "\r\n" "\n" $ strip string)
|
||||
encoded [] = oneLine string
|
||||
encoded [_] = oneLine string
|
||||
encoded lines'' = start <> transformLines lines'' <> end
|
||||
transformLines = foldr ((\line acc -> line <> Builder.singleton '\n' <> acc) . transformLine) mempty
|
||||
transformLine line =
|
||||
if Lazy.Text.null (Builder.toLazyText line)
|
||||
then line
|
||||
else Builder.fromLazyText (indent (indentation + 1)) <> line
|
||||
|
||||
escape :: Char -> Builder
|
||||
escape char'
|
||||
|
@ -228,7 +262,9 @@ escape char'
|
|||
| char' == '\"' = Builder.fromString "\\\""
|
||||
| char' == '\b' = Builder.fromString "\\b"
|
||||
| char' == '\f' = Builder.fromString "\\f"
|
||||
| char' == '\n' = Builder.fromString "\\n"
|
||||
| char' == '\r' = Builder.fromString "\\r"
|
||||
| char' == '\t' = Builder.fromString "\\t"
|
||||
| char' < '\x0010' = unicode "\\u000" char'
|
||||
| char' < '\x0020' = unicode "\\u00" char'
|
||||
| otherwise = Builder.singleton char'
|
||||
|
|
|
@ -15,6 +15,7 @@ module Language.GraphQL.AST.Lexer
|
|||
, dollar
|
||||
, comment
|
||||
, equals
|
||||
, extend
|
||||
, integer
|
||||
, float
|
||||
, lexeme
|
||||
|
@ -28,20 +29,16 @@ module Language.GraphQL.AST.Lexer
|
|||
, unicodeBOM
|
||||
) where
|
||||
|
||||
import Control.Applicative ( Alternative(..)
|
||||
, liftA2
|
||||
)
|
||||
import Data.Char ( chr
|
||||
, digitToInt
|
||||
, isAsciiLower
|
||||
, isAsciiUpper
|
||||
, ord
|
||||
)
|
||||
import Control.Applicative (Alternative(..), liftA2)
|
||||
import Data.Char (chr, digitToInt, isAsciiLower, isAsciiUpper, ord)
|
||||
import Data.Foldable (foldl')
|
||||
import Data.List (dropWhileEnd)
|
||||
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
|
||||
|
@ -56,11 +53,9 @@ import Text.Megaparsec ( Parsec
|
|||
, takeWhile1P
|
||||
, try
|
||||
)
|
||||
import Text.Megaparsec.Char ( char
|
||||
, digitChar
|
||||
, space1
|
||||
)
|
||||
import Text.Megaparsec.Char (char, digitChar, space1)
|
||||
import qualified Text.Megaparsec.Char.Lexer as Lexer
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.Lazy as TL
|
||||
|
||||
|
@ -97,8 +92,8 @@ dollar :: Parser T.Text
|
|||
dollar = symbol "$"
|
||||
|
||||
-- | Parser for "@".
|
||||
at :: Parser Char
|
||||
at = char '@'
|
||||
at :: Parser Text
|
||||
at = symbol "@"
|
||||
|
||||
-- | Parser for "&".
|
||||
amp :: Parser T.Text
|
||||
|
@ -134,7 +129,7 @@ braces = between (symbol "{") (symbol "}")
|
|||
|
||||
-- | Parser for strings.
|
||||
string :: Parser T.Text
|
||||
string = between "\"" "\"" stringValue <* spaceConsumer
|
||||
string = between "\"" "\"" stringValue <* spaceConsumer
|
||||
where
|
||||
stringValue = T.pack <$> many stringCharacter
|
||||
stringCharacter = satisfy isStringCharacter1
|
||||
|
@ -143,7 +138,7 @@ string = between "\"" "\"" stringValue <* spaceConsumer
|
|||
|
||||
-- | Parser for block strings.
|
||||
blockString :: Parser T.Text
|
||||
blockString = between "\"\"\"" "\"\"\"" stringValue <* spaceConsumer
|
||||
blockString = between "\"\"\"" "\"\"\"" stringValue <* spaceConsumer
|
||||
where
|
||||
stringValue = do
|
||||
byLine <- sepBy (many blockStringCharacter) lineTerminator
|
||||
|
@ -226,3 +221,16 @@ escapeSequence = do
|
|||
-- | Parser for the "Byte Order Mark".
|
||||
unicodeBOM :: Parser ()
|
||||
unicodeBOM = optional (char '\xfeff') >> pure ()
|
||||
|
||||
-- | Parses "extend" followed by a 'symbol'. It is used by schema extensions.
|
||||
extend :: forall a. Text -> String -> NonEmpty (Parser a) -> Parser a
|
||||
extend token extensionLabel parsers
|
||||
= foldr combine headParser (NonEmpty.tail parsers)
|
||||
<?> extensionLabel
|
||||
where
|
||||
headParser = tryExtension $ NonEmpty.head parsers
|
||||
combine current accumulated = accumulated <|> tryExtension current
|
||||
tryExtension extensionParser = try
|
||||
$ symbol "extend"
|
||||
*> symbol token
|
||||
*> extensionParser
|
|
@ -6,63 +6,358 @@ module Language.GraphQL.AST.Parser
|
|||
( document
|
||||
) where
|
||||
|
||||
import Control.Applicative ( Alternative(..)
|
||||
, optional
|
||||
)
|
||||
import Control.Applicative (Alternative(..), optional)
|
||||
import Control.Applicative.Combinators (sepBy1)
|
||||
import qualified Control.Applicative.Combinators.NonEmpty as NonEmpty
|
||||
import Data.List.NonEmpty (NonEmpty(..))
|
||||
import Language.GraphQL.AST
|
||||
import Data.Text (Text)
|
||||
import qualified Language.GraphQL.AST.DirectiveLocation as Directive
|
||||
import Language.GraphQL.AST.DirectiveLocation
|
||||
( DirectiveLocation
|
||||
, ExecutableDirectiveLocation
|
||||
, TypeSystemDirectiveLocation
|
||||
)
|
||||
import Language.GraphQL.AST.Document
|
||||
import Language.GraphQL.AST.Lexer
|
||||
import Text.Megaparsec ( lookAhead
|
||||
, option
|
||||
, try
|
||||
, (<?>)
|
||||
)
|
||||
import Text.Megaparsec (lookAhead, option, try, (<?>))
|
||||
|
||||
-- | Parser for the GraphQL documents.
|
||||
document :: Parser Document
|
||||
document = unicodeBOM >> spaceConsumer >> lexeme (manyNE definition)
|
||||
document = unicodeBOM
|
||||
>> spaceConsumer
|
||||
>> lexeme (NonEmpty.some definition)
|
||||
|
||||
definition :: Parser Definition
|
||||
definition = DefinitionOperation <$> operationDefinition
|
||||
<|> DefinitionFragment <$> fragmentDefinition
|
||||
<?> "definition error!"
|
||||
definition = ExecutableDefinition <$> executableDefinition
|
||||
<|> TypeSystemDefinition <$> typeSystemDefinition
|
||||
<|> TypeSystemExtension <$> typeSystemExtension
|
||||
<?> "Definition"
|
||||
|
||||
executableDefinition :: Parser ExecutableDefinition
|
||||
executableDefinition = DefinitionOperation <$> operationDefinition
|
||||
<|> DefinitionFragment <$> fragmentDefinition
|
||||
<?> "ExecutableDefinition"
|
||||
|
||||
typeSystemDefinition :: Parser TypeSystemDefinition
|
||||
typeSystemDefinition = schemaDefinition
|
||||
<|> TypeDefinition <$> typeDefinition
|
||||
<|> directiveDefinition
|
||||
<?> "TypeSystemDefinition"
|
||||
|
||||
typeSystemExtension :: Parser TypeSystemExtension
|
||||
typeSystemExtension = SchemaExtension <$> schemaExtension
|
||||
<|> TypeExtension <$> typeExtension
|
||||
<?> "TypeSystemExtension"
|
||||
|
||||
directiveDefinition :: Parser TypeSystemDefinition
|
||||
directiveDefinition = DirectiveDefinition
|
||||
<$> description
|
||||
<* symbol "directive"
|
||||
<* at
|
||||
<*> name
|
||||
<*> argumentsDefinition
|
||||
<* symbol "on"
|
||||
<*> directiveLocations
|
||||
<?> "DirectiveDefinition"
|
||||
|
||||
directiveLocations :: Parser (NonEmpty DirectiveLocation)
|
||||
directiveLocations = optional pipe
|
||||
*> directiveLocation `NonEmpty.sepBy1` pipe
|
||||
|
||||
directiveLocation :: Parser DirectiveLocation
|
||||
directiveLocation
|
||||
= Directive.ExecutableDirectiveLocation <$> executableDirectiveLocation
|
||||
<|> Directive.TypeSystemDirectiveLocation <$> typeSystemDirectiveLocation
|
||||
|
||||
executableDirectiveLocation :: Parser ExecutableDirectiveLocation
|
||||
executableDirectiveLocation = Directive.Query <$ symbol "QUERY"
|
||||
<|> Directive.Mutation <$ symbol "MUTATION"
|
||||
<|> Directive.Subscription <$ symbol "SUBSCRIPTION"
|
||||
<|> Directive.Field <$ symbol "FIELD"
|
||||
<|> Directive.FragmentDefinition <$ "FRAGMENT_DEFINITION"
|
||||
<|> Directive.FragmentSpread <$ "FRAGMENT_SPREAD"
|
||||
<|> Directive.InlineFragment <$ "INLINE_FRAGMENT"
|
||||
|
||||
typeSystemDirectiveLocation :: Parser TypeSystemDirectiveLocation
|
||||
typeSystemDirectiveLocation = Directive.Schema <$ symbol "SCHEMA"
|
||||
<|> Directive.Scalar <$ symbol "SCALAR"
|
||||
<|> Directive.Object <$ symbol "OBJECT"
|
||||
<|> Directive.FieldDefinition <$ symbol "FIELD_DEFINITION"
|
||||
<|> Directive.ArgumentDefinition <$ symbol "ARGUMENT_DEFINITION"
|
||||
<|> Directive.Interface <$ symbol "INTERFACE"
|
||||
<|> Directive.Union <$ symbol "UNION"
|
||||
<|> Directive.Enum <$ symbol "ENUM"
|
||||
<|> Directive.EnumValue <$ symbol "ENUM_VALUE"
|
||||
<|> Directive.InputObject <$ symbol "INPUT_OBJECT"
|
||||
<|> Directive.InputFieldDefinition <$ symbol "INPUT_FIELD_DEFINITION"
|
||||
|
||||
typeDefinition :: Parser TypeDefinition
|
||||
typeDefinition = scalarTypeDefinition
|
||||
<|> objectTypeDefinition
|
||||
<|> interfaceTypeDefinition
|
||||
<|> unionTypeDefinition
|
||||
<|> enumTypeDefinition
|
||||
<|> inputObjectTypeDefinition
|
||||
<?> "TypeDefinition"
|
||||
|
||||
typeExtension :: Parser TypeExtension
|
||||
typeExtension = scalarTypeExtension
|
||||
<|> objectTypeExtension
|
||||
<|> interfaceTypeExtension
|
||||
<|> unionTypeExtension
|
||||
<|> enumTypeExtension
|
||||
<|> inputObjectTypeExtension
|
||||
<?> "TypeExtension"
|
||||
|
||||
scalarTypeDefinition :: Parser TypeDefinition
|
||||
scalarTypeDefinition = ScalarTypeDefinition
|
||||
<$> description
|
||||
<* symbol "scalar"
|
||||
<*> name
|
||||
<*> directives
|
||||
<?> "ScalarTypeDefinition"
|
||||
|
||||
scalarTypeExtension :: Parser TypeExtension
|
||||
scalarTypeExtension = extend "scalar" "ScalarTypeExtension"
|
||||
$ (ScalarTypeExtension <$> name <*> NonEmpty.some directive) :| []
|
||||
|
||||
objectTypeDefinition :: Parser TypeDefinition
|
||||
objectTypeDefinition = ObjectTypeDefinition
|
||||
<$> description
|
||||
<* symbol "type"
|
||||
<*> name
|
||||
<*> option (ImplementsInterfaces []) (implementsInterfaces sepBy1)
|
||||
<*> directives
|
||||
<*> braces (many fieldDefinition)
|
||||
<?> "ObjectTypeDefinition"
|
||||
|
||||
objectTypeExtension :: Parser TypeExtension
|
||||
objectTypeExtension = extend "type" "ObjectTypeExtension"
|
||||
$ fieldsDefinitionExtension :|
|
||||
[ directivesExtension
|
||||
, implementsInterfacesExtension
|
||||
]
|
||||
where
|
||||
fieldsDefinitionExtension = ObjectTypeFieldsDefinitionExtension
|
||||
<$> name
|
||||
<*> option (ImplementsInterfaces []) (implementsInterfaces sepBy1)
|
||||
<*> directives
|
||||
<*> braces (NonEmpty.some fieldDefinition)
|
||||
directivesExtension = ObjectTypeDirectivesExtension
|
||||
<$> name
|
||||
<*> option (ImplementsInterfaces []) (implementsInterfaces sepBy1)
|
||||
<*> NonEmpty.some directive
|
||||
implementsInterfacesExtension = ObjectTypeImplementsInterfacesExtension
|
||||
<$> name
|
||||
<*> implementsInterfaces NonEmpty.sepBy1
|
||||
|
||||
description :: Parser Description
|
||||
description = Description
|
||||
<$> optional (string <|> blockString)
|
||||
<?> "Description"
|
||||
|
||||
unionTypeDefinition :: Parser TypeDefinition
|
||||
unionTypeDefinition = UnionTypeDefinition
|
||||
<$> description
|
||||
<* symbol "union"
|
||||
<*> name
|
||||
<*> directives
|
||||
<*> option (UnionMemberTypes []) (unionMemberTypes sepBy1)
|
||||
<?> "UnionTypeDefinition"
|
||||
|
||||
unionTypeExtension :: Parser TypeExtension
|
||||
unionTypeExtension = extend "union" "UnionTypeExtension"
|
||||
$ unionMemberTypesExtension :| [directivesExtension]
|
||||
where
|
||||
unionMemberTypesExtension = UnionTypeUnionMemberTypesExtension
|
||||
<$> name
|
||||
<*> directives
|
||||
<*> unionMemberTypes NonEmpty.sepBy1
|
||||
directivesExtension = UnionTypeDirectivesExtension
|
||||
<$> name
|
||||
<*> NonEmpty.some directive
|
||||
|
||||
unionMemberTypes ::
|
||||
Foldable t =>
|
||||
(Parser Text -> Parser Text -> Parser (t NamedType)) ->
|
||||
Parser (UnionMemberTypes t)
|
||||
unionMemberTypes sepBy' = UnionMemberTypes
|
||||
<$ equals
|
||||
<* optional pipe
|
||||
<*> name `sepBy'` pipe
|
||||
<?> "UnionMemberTypes"
|
||||
|
||||
interfaceTypeDefinition :: Parser TypeDefinition
|
||||
interfaceTypeDefinition = InterfaceTypeDefinition
|
||||
<$> description
|
||||
<* symbol "interface"
|
||||
<*> name
|
||||
<*> directives
|
||||
<*> braces (many fieldDefinition)
|
||||
<?> "InterfaceTypeDefinition"
|
||||
|
||||
interfaceTypeExtension :: Parser TypeExtension
|
||||
interfaceTypeExtension = extend "interface" "InterfaceTypeExtension"
|
||||
$ fieldsDefinitionExtension :| [directivesExtension]
|
||||
where
|
||||
fieldsDefinitionExtension = InterfaceTypeFieldsDefinitionExtension
|
||||
<$> name
|
||||
<*> directives
|
||||
<*> braces (NonEmpty.some fieldDefinition)
|
||||
directivesExtension = InterfaceTypeDirectivesExtension
|
||||
<$> name
|
||||
<*> NonEmpty.some directive
|
||||
|
||||
enumTypeDefinition :: Parser TypeDefinition
|
||||
enumTypeDefinition = EnumTypeDefinition
|
||||
<$> description
|
||||
<* symbol "enum"
|
||||
<*> name
|
||||
<*> directives
|
||||
<*> listOptIn braces enumValueDefinition
|
||||
<?> "EnumTypeDefinition"
|
||||
|
||||
enumTypeExtension :: Parser TypeExtension
|
||||
enumTypeExtension = extend "enum" "EnumTypeExtension"
|
||||
$ enumValuesDefinitionExtension :| [directivesExtension]
|
||||
where
|
||||
enumValuesDefinitionExtension = EnumTypeEnumValuesDefinitionExtension
|
||||
<$> name
|
||||
<*> directives
|
||||
<*> braces (NonEmpty.some enumValueDefinition)
|
||||
directivesExtension = EnumTypeDirectivesExtension
|
||||
<$> name
|
||||
<*> NonEmpty.some directive
|
||||
|
||||
inputObjectTypeDefinition :: Parser TypeDefinition
|
||||
inputObjectTypeDefinition = InputObjectTypeDefinition
|
||||
<$> description
|
||||
<* symbol "input"
|
||||
<*> name
|
||||
<*> directives
|
||||
<*> listOptIn braces inputValueDefinition
|
||||
<?> "InputObjectTypeDefinition"
|
||||
|
||||
inputObjectTypeExtension :: Parser TypeExtension
|
||||
inputObjectTypeExtension = extend "input" "InputObjectTypeExtension"
|
||||
$ inputFieldsDefinitionExtension :| [directivesExtension]
|
||||
where
|
||||
inputFieldsDefinitionExtension = InputObjectTypeInputFieldsDefinitionExtension
|
||||
<$> name
|
||||
<*> directives
|
||||
<*> braces (NonEmpty.some inputValueDefinition)
|
||||
directivesExtension = InputObjectTypeDirectivesExtension
|
||||
<$> name
|
||||
<*> NonEmpty.some directive
|
||||
|
||||
enumValueDefinition :: Parser EnumValueDefinition
|
||||
enumValueDefinition = EnumValueDefinition
|
||||
<$> description
|
||||
<*> enumValue
|
||||
<*> directives
|
||||
<?> "EnumValueDefinition"
|
||||
|
||||
implementsInterfaces ::
|
||||
Foldable t =>
|
||||
(Parser Text -> Parser Text -> Parser (t NamedType)) ->
|
||||
Parser (ImplementsInterfaces t)
|
||||
implementsInterfaces sepBy' = ImplementsInterfaces
|
||||
<$ symbol "implements"
|
||||
<* optional amp
|
||||
<*> name `sepBy'` amp
|
||||
<?> "ImplementsInterfaces"
|
||||
|
||||
inputValueDefinition :: Parser InputValueDefinition
|
||||
inputValueDefinition = InputValueDefinition
|
||||
<$> description
|
||||
<*> name
|
||||
<* colon
|
||||
<*> type'
|
||||
<*> defaultValue
|
||||
<*> directives
|
||||
<?> "InputValueDefinition"
|
||||
|
||||
argumentsDefinition :: Parser ArgumentsDefinition
|
||||
argumentsDefinition = ArgumentsDefinition
|
||||
<$> listOptIn parens inputValueDefinition
|
||||
<?> "ArgumentsDefinition"
|
||||
|
||||
fieldDefinition :: Parser FieldDefinition
|
||||
fieldDefinition = FieldDefinition
|
||||
<$> description
|
||||
<*> name
|
||||
<*> argumentsDefinition
|
||||
<* colon
|
||||
<*> type'
|
||||
<*> directives
|
||||
<?> "FieldDefinition"
|
||||
|
||||
schemaDefinition :: Parser TypeSystemDefinition
|
||||
schemaDefinition = SchemaDefinition
|
||||
<$ symbol "schema"
|
||||
<*> directives
|
||||
<*> operationTypeDefinitions
|
||||
<?> "SchemaDefinition"
|
||||
|
||||
operationTypeDefinitions :: Parser (NonEmpty OperationTypeDefinition)
|
||||
operationTypeDefinitions = braces $ NonEmpty.some operationTypeDefinition
|
||||
|
||||
schemaExtension :: Parser SchemaExtension
|
||||
schemaExtension = extend "schema" "SchemaExtension"
|
||||
$ schemaOperationExtension :| [directivesExtension]
|
||||
where
|
||||
directivesExtension = SchemaDirectivesExtension
|
||||
<$> NonEmpty.some directive
|
||||
schemaOperationExtension = SchemaOperationExtension
|
||||
<$> directives
|
||||
<*> operationTypeDefinitions
|
||||
|
||||
operationTypeDefinition :: Parser OperationTypeDefinition
|
||||
operationTypeDefinition = OperationTypeDefinition
|
||||
<$> operationType <* colon
|
||||
<*> name
|
||||
<?> "OperationTypeDefinition"
|
||||
|
||||
operationDefinition :: Parser OperationDefinition
|
||||
operationDefinition = OperationSelectionSet <$> selectionSet
|
||||
<|> OperationDefinition <$> operationType
|
||||
<*> optional name
|
||||
<*> opt variableDefinitions
|
||||
<*> opt directives
|
||||
<*> selectionSet
|
||||
<?> "operationDefinition error"
|
||||
operationDefinition = SelectionSet <$> selectionSet
|
||||
<|> operationDefinition'
|
||||
<?> "operationDefinition error"
|
||||
where
|
||||
operationDefinition'
|
||||
= OperationDefinition <$> operationType
|
||||
<*> optional name
|
||||
<*> variableDefinitions
|
||||
<*> directives
|
||||
<*> selectionSet
|
||||
|
||||
operationType :: Parser OperationType
|
||||
operationType = Query <$ symbol "query"
|
||||
<|> Mutation <$ symbol "mutation"
|
||||
<?> "operationType error"
|
||||
-- <?> Keep default error message
|
||||
|
||||
-- * SelectionSet
|
||||
|
||||
selectionSet :: Parser SelectionSet
|
||||
selectionSet = braces $ manyNE selection
|
||||
selectionSet = braces $ NonEmpty.some selection
|
||||
|
||||
selectionSetOpt :: Parser SelectionSetOpt
|
||||
selectionSetOpt = braces $ some selection
|
||||
selectionSetOpt = listOptIn braces selection
|
||||
|
||||
selection :: Parser Selection
|
||||
selection = SelectionField <$> field
|
||||
<|> try (SelectionFragmentSpread <$> fragmentSpread)
|
||||
<|> SelectionInlineFragment <$> inlineFragment
|
||||
<?> "selection error!"
|
||||
selection = field
|
||||
<|> try fragmentSpread
|
||||
<|> inlineFragment
|
||||
<?> "selection error!"
|
||||
|
||||
-- * Field
|
||||
|
||||
field :: Parser Field
|
||||
field = Field <$> optional alias
|
||||
<*> name
|
||||
<*> opt arguments
|
||||
<*> opt directives
|
||||
<*> opt selectionSetOpt
|
||||
field :: Parser Selection
|
||||
field = Field
|
||||
<$> optional alias
|
||||
<*> name
|
||||
<*> arguments
|
||||
<*> directives
|
||||
<*> selectionSetOpt
|
||||
|
||||
alias :: Parser Alias
|
||||
alias = try $ name <* colon
|
||||
|
@ -70,30 +365,32 @@ alias = try $ name <* colon
|
|||
-- * Arguments
|
||||
|
||||
arguments :: Parser [Argument]
|
||||
arguments = parens $ some argument
|
||||
arguments = listOptIn parens argument
|
||||
|
||||
argument :: Parser Argument
|
||||
argument = Argument <$> name <* colon <*> value
|
||||
|
||||
-- * Fragments
|
||||
|
||||
fragmentSpread :: Parser FragmentSpread
|
||||
fragmentSpread = FragmentSpread <$ spread
|
||||
<*> fragmentName
|
||||
<*> opt directives
|
||||
fragmentSpread :: Parser Selection
|
||||
fragmentSpread = FragmentSpread
|
||||
<$ spread
|
||||
<*> fragmentName
|
||||
<*> directives
|
||||
|
||||
inlineFragment :: Parser InlineFragment
|
||||
inlineFragment = InlineFragment <$ spread
|
||||
<*> optional typeCondition
|
||||
<*> opt directives
|
||||
<*> selectionSet
|
||||
inlineFragment :: Parser Selection
|
||||
inlineFragment = InlineFragment
|
||||
<$ spread
|
||||
<*> optional typeCondition
|
||||
<*> directives
|
||||
<*> selectionSet
|
||||
|
||||
fragmentDefinition :: Parser FragmentDefinition
|
||||
fragmentDefinition = FragmentDefinition
|
||||
<$ symbol "fragment"
|
||||
<*> name
|
||||
<*> typeCondition
|
||||
<*> opt directives
|
||||
<*> directives
|
||||
<*> selectionSet
|
||||
|
||||
fragmentName :: Parser Name
|
||||
|
@ -121,68 +418,68 @@ value = Variable <$> variable
|
|||
booleanValue = True <$ symbol "true"
|
||||
<|> False <$ symbol "false"
|
||||
|
||||
enumValue :: Parser Name
|
||||
enumValue = but (symbol "true") *> but (symbol "false") *> but (symbol "null") *> name
|
||||
|
||||
listValue :: Parser [Value]
|
||||
listValue = brackets $ some value
|
||||
|
||||
objectValue :: Parser [ObjectField]
|
||||
objectValue = braces $ some objectField
|
||||
|
||||
enumValue :: Parser Name
|
||||
enumValue = but (symbol "true") *> but (symbol "false") *> but (symbol "null") *> name
|
||||
|
||||
objectField :: Parser ObjectField
|
||||
objectField = ObjectField <$> name <* symbol ":" <*> value
|
||||
objectField = ObjectField <$> name <* colon <*> value
|
||||
|
||||
-- * Variables
|
||||
|
||||
variableDefinitions :: Parser [VariableDefinition]
|
||||
variableDefinitions = parens $ some variableDefinition
|
||||
variableDefinitions = listOptIn parens variableDefinition
|
||||
|
||||
variableDefinition :: Parser VariableDefinition
|
||||
variableDefinition = VariableDefinition <$> variable
|
||||
<* colon
|
||||
<*> type_
|
||||
<*> optional defaultValue
|
||||
variableDefinition = VariableDefinition
|
||||
<$> variable
|
||||
<* colon
|
||||
<*> type'
|
||||
<*> defaultValue
|
||||
<?> "VariableDefinition"
|
||||
|
||||
variable :: Parser Name
|
||||
variable = dollar *> name
|
||||
|
||||
defaultValue :: Parser Value
|
||||
defaultValue = equals *> value
|
||||
defaultValue :: Parser (Maybe Value)
|
||||
defaultValue = optional (equals *> value) <?> "DefaultValue"
|
||||
|
||||
-- * Input Types
|
||||
|
||||
type_ :: Parser Type
|
||||
type_ = try (TypeNonNull <$> nonNullType)
|
||||
<|> TypeList <$> brackets type_
|
||||
type' :: Parser Type
|
||||
type' = try (TypeNonNull <$> nonNullType)
|
||||
<|> TypeList <$> brackets type'
|
||||
<|> TypeNamed <$> name
|
||||
<?> "type_ error!"
|
||||
<?> "Type"
|
||||
|
||||
nonNullType :: Parser NonNullType
|
||||
nonNullType = NonNullTypeNamed <$> name <* bang
|
||||
<|> NonNullTypeList <$> brackets type_ <* bang
|
||||
<|> NonNullTypeList <$> brackets type' <* bang
|
||||
<?> "nonNullType error!"
|
||||
|
||||
-- * Directives
|
||||
|
||||
directives :: Parser [Directive]
|
||||
directives = some directive
|
||||
directives = many directive
|
||||
|
||||
directive :: Parser Directive
|
||||
directive = Directive
|
||||
<$ at
|
||||
<*> name
|
||||
<*> opt arguments
|
||||
<$ at
|
||||
<*> name
|
||||
<*> arguments
|
||||
|
||||
-- * Internal
|
||||
|
||||
opt :: Monoid a => Parser a -> Parser a
|
||||
opt = option mempty
|
||||
listOptIn :: (Parser [a] -> Parser [a]) -> Parser a -> Parser [a]
|
||||
listOptIn surround = option [] . surround . some
|
||||
|
||||
-- Hack to reverse parser success
|
||||
but :: Parser a -> Parser ()
|
||||
but pn = False <$ lookAhead pn <|> pure True >>= \case
|
||||
False -> empty
|
||||
True -> pure ()
|
||||
|
||||
manyNE :: Alternative f => f a -> f (NonEmpty a)
|
||||
manyNE p = (:|) <$> p <*> many p
|
||||
|
|
|
@ -20,18 +20,20 @@ import Control.Monad.Trans.State ( StateT
|
|||
, modify
|
||||
, runStateT
|
||||
)
|
||||
import Text.Megaparsec ( ParseErrorBundle(..)
|
||||
, SourcePos(..)
|
||||
, errorOffset
|
||||
, parseErrorTextPretty
|
||||
, reachOffset
|
||||
, unPos
|
||||
)
|
||||
import Text.Megaparsec
|
||||
( ParseErrorBundle(..)
|
||||
, PosState(..)
|
||||
, SourcePos(..)
|
||||
, errorOffset
|
||||
, parseErrorTextPretty
|
||||
, reachOffset
|
||||
, unPos
|
||||
)
|
||||
|
||||
-- | Wraps a parse error into a list of errors.
|
||||
parseError :: Applicative f => ParseErrorBundle Text Void -> f Aeson.Value
|
||||
parseError ParseErrorBundle{..} =
|
||||
pure $ Aeson.object [("errors", Aeson.toJSON $ fst $ foldl go ([], bundlePosState) bundleErrors)]
|
||||
pure $ Aeson.object [("errors", Aeson.toJSON $ fst $ foldl go ([], bundlePosState) bundleErrors)]
|
||||
where
|
||||
errorObject s SourcePos{..} = Aeson.object
|
||||
[ ("message", Aeson.toJSON $ init $ parseErrorTextPretty s)
|
||||
|
@ -39,7 +41,8 @@ parseError ParseErrorBundle{..} =
|
|||
, ("column", Aeson.toJSON $ unPos sourceColumn)
|
||||
]
|
||||
go (result, state) x =
|
||||
let (sourcePosition, _, newState) = reachOffset (errorOffset x) state
|
||||
let (_, newState) = reachOffset (errorOffset x) state
|
||||
sourcePosition = pstateSourcePos newState
|
||||
in (errorObject x sourcePosition : result, newState)
|
||||
|
||||
-- | A wrapper to pass error messages around.
|
||||
|
|
|
@ -6,14 +6,14 @@ module Language.GraphQL.Execute
|
|||
, executeWithName
|
||||
) where
|
||||
|
||||
import Control.Monad.IO.Class (MonadIO)
|
||||
import qualified Data.Aeson as Aeson
|
||||
import Data.Foldable (toList)
|
||||
import Data.List.NonEmpty (NonEmpty(..))
|
||||
import qualified Data.List.NonEmpty as NE
|
||||
import qualified Data.List.NonEmpty as NonEmpty
|
||||
import Data.HashMap.Strict (HashMap)
|
||||
import qualified Data.HashMap.Strict as HashMap
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as Text
|
||||
import qualified Language.GraphQL.AST as AST
|
||||
import Language.GraphQL.AST.Document
|
||||
import qualified Language.GraphQL.AST.Core as AST.Core
|
||||
import qualified Language.GraphQL.Execute.Transform as Transform
|
||||
import Language.GraphQL.Error
|
||||
|
@ -24,13 +24,14 @@ import qualified Language.GraphQL.Schema as Schema
|
|||
--
|
||||
-- Returns the result of the query against the schema wrapped in a /data/
|
||||
-- field, or errors wrapped in an /errors/ field.
|
||||
execute :: MonadIO m
|
||||
=> NonEmpty (Schema.Resolver m) -- ^ Resolvers.
|
||||
execute :: Monad m
|
||||
=> HashMap Text (NonEmpty (Schema.Resolver m)) -- ^ Resolvers.
|
||||
-> Schema.Subs -- ^ Variable substitution function.
|
||||
-> AST.Document -- @GraphQL@ document.
|
||||
-> Document -- @GraphQL@ document.
|
||||
-> m Aeson.Value
|
||||
execute schema subs doc =
|
||||
maybe transformError (document schema Nothing) $ Transform.document subs doc
|
||||
maybe transformError (document schema Nothing)
|
||||
$ Transform.document subs doc
|
||||
where
|
||||
transformError = return $ singleError "Schema transformation error."
|
||||
|
||||
|
@ -40,24 +41,25 @@ execute schema subs doc =
|
|||
--
|
||||
-- Returns the result of the query against the schema wrapped in a /data/
|
||||
-- field, or errors wrapped in an /errors/ field.
|
||||
executeWithName :: MonadIO m
|
||||
=> NonEmpty (Schema.Resolver m) -- ^ Resolvers
|
||||
executeWithName :: Monad m
|
||||
=> HashMap Text (NonEmpty (Schema.Resolver m)) -- ^ Resolvers
|
||||
-> Text -- ^ Operation name.
|
||||
-> Schema.Subs -- ^ Variable substitution function.
|
||||
-> AST.Document -- ^ @GraphQL@ Document.
|
||||
-> Document -- ^ @GraphQL@ Document.
|
||||
-> m Aeson.Value
|
||||
executeWithName schema name subs doc =
|
||||
maybe transformError (document schema $ Just name) $ Transform.document subs doc
|
||||
maybe transformError (document schema $ Just name)
|
||||
$ Transform.document subs doc
|
||||
where
|
||||
transformError = return $ singleError "Schema transformation error."
|
||||
|
||||
document :: MonadIO m
|
||||
=> NonEmpty (Schema.Resolver m)
|
||||
document :: Monad m
|
||||
=> HashMap Text (NonEmpty (Schema.Resolver m))
|
||||
-> Maybe Text
|
||||
-> AST.Core.Document
|
||||
-> m Aeson.Value
|
||||
document schema Nothing (op :| []) = operation schema op
|
||||
document schema (Just name) operations = case NE.dropWhile matchingName operations of
|
||||
document schema (Just name) operations = case NonEmpty.dropWhile matchingName operations of
|
||||
[] -> return $ singleError
|
||||
$ Text.unwords ["Operation", name, "couldn't be found in the document."]
|
||||
(op:_) -> operation schema op
|
||||
|
@ -67,11 +69,18 @@ document schema (Just name) operations = case NE.dropWhile matchingName operatio
|
|||
matchingName _ = False
|
||||
document _ _ _ = return $ singleError "Missing operation name."
|
||||
|
||||
operation :: MonadIO m
|
||||
=> NonEmpty (Schema.Resolver m)
|
||||
operation :: Monad m
|
||||
=> HashMap Text (NonEmpty (Schema.Resolver m))
|
||||
-> AST.Core.Operation
|
||||
-> m Aeson.Value
|
||||
operation schema (AST.Core.Query _ flds)
|
||||
= runCollectErrs (Schema.resolve (toList schema) flds)
|
||||
operation schema (AST.Core.Mutation _ flds)
|
||||
= runCollectErrs (Schema.resolve (toList schema) flds)
|
||||
operation schema = schemaOperation
|
||||
where
|
||||
runResolver fields = runCollectErrs
|
||||
. flip Schema.resolve fields
|
||||
. Schema.resolversToMap
|
||||
resolve fields queryType = maybe lookupError (runResolver fields)
|
||||
$ HashMap.lookup queryType schema
|
||||
lookupError = pure
|
||||
$ singleError "Root operation type couldn't be found in the schema."
|
||||
schemaOperation (AST.Core.Query _ fields) = resolve fields "Query"
|
||||
schemaOperation (AST.Core.Mutation _ fields) = resolve fields "Mutation"
|
||||
|
|
|
@ -11,7 +11,7 @@ module Language.GraphQL.Execute.Transform
|
|||
import Control.Arrow (first)
|
||||
import Control.Monad (foldM, unless)
|
||||
import Control.Monad.Trans.Class (lift)
|
||||
import Control.Monad.Trans.Reader (ReaderT, ask, runReaderT)
|
||||
import Control.Monad.Trans.Reader (ReaderT, asks, runReaderT)
|
||||
import Control.Monad.Trans.State (StateT, evalStateT, gets, modify)
|
||||
import Data.HashMap.Strict (HashMap)
|
||||
import qualified Data.HashMap.Strict as HashMap
|
||||
|
@ -19,6 +19,7 @@ import qualified Data.List.NonEmpty as NonEmpty
|
|||
import Data.Sequence (Seq, (<|), (><))
|
||||
import qualified Language.GraphQL.AST as Full
|
||||
import qualified Language.GraphQL.AST.Core as Core
|
||||
import Language.GraphQL.AST.Document (Definition(..), Document)
|
||||
import qualified Language.GraphQL.Schema as Schema
|
||||
import qualified Language.GraphQL.Type.Directive as Directive
|
||||
|
||||
|
@ -35,18 +36,19 @@ liftJust = lift . lift . Just
|
|||
|
||||
-- | Rewrites the original syntax tree into an intermediate representation used
|
||||
-- for query execution.
|
||||
document :: Schema.Subs -> Full.Document -> Maybe Core.Document
|
||||
document :: Schema.Subs -> Document -> Maybe Core.Document
|
||||
document subs document' =
|
||||
flip runReaderT subs
|
||||
$ evalStateT (collectFragments >> operations operationDefinitions)
|
||||
$ Replacement HashMap.empty fragmentTable
|
||||
where
|
||||
(fragmentTable, operationDefinitions) = foldr defragment mempty document'
|
||||
defragment (Full.DefinitionOperation definition) acc =
|
||||
defragment (ExecutableDefinition (Full.DefinitionOperation definition)) acc =
|
||||
(definition :) <$> acc
|
||||
defragment (Full.DefinitionFragment definition) acc =
|
||||
defragment (ExecutableDefinition (Full.DefinitionFragment definition)) acc =
|
||||
let (Full.FragmentDefinition name _ _ _) = definition
|
||||
in first (HashMap.insert name definition) acc
|
||||
defragment _ acc = acc
|
||||
|
||||
-- * Operation
|
||||
|
||||
|
@ -56,26 +58,47 @@ operations operations' = do
|
|||
lift . lift $ NonEmpty.nonEmpty coreOperations
|
||||
|
||||
operation :: Full.OperationDefinition -> TransformT Core.Operation
|
||||
operation (Full.OperationSelectionSet sels) =
|
||||
operation $ Full.OperationDefinition Full.Query mempty mempty mempty sels
|
||||
-- TODO: Validate Variable definitions with substituter
|
||||
operation (Full.OperationDefinition Full.Query name _vars _dirs sels) =
|
||||
Core.Query name <$> appendSelection sels
|
||||
operation (Full.OperationDefinition Full.Mutation name _vars _dirs sels) =
|
||||
Core.Mutation name <$> appendSelection sels
|
||||
operation (Full.SelectionSet sels)
|
||||
= operation $ Full.OperationDefinition Full.Query mempty mempty mempty sels
|
||||
operation (Full.OperationDefinition Full.Query name _vars _dirs sels)
|
||||
= Core.Query name <$> appendSelection sels
|
||||
operation (Full.OperationDefinition Full.Mutation name _vars _dirs sels)
|
||||
= Core.Mutation name <$> appendSelection sels
|
||||
|
||||
-- * Selection
|
||||
|
||||
selection ::
|
||||
Full.Selection ->
|
||||
TransformT (Either (Seq Core.Selection) Core.Selection)
|
||||
selection (Full.SelectionField field') =
|
||||
maybe (Left mempty) (Right . Core.SelectionField) <$> field field'
|
||||
selection (Full.SelectionFragmentSpread fragment) =
|
||||
maybe (Left mempty) (Right . Core.SelectionFragment)
|
||||
<$> fragmentSpread fragment
|
||||
selection (Full.SelectionInlineFragment fragment) =
|
||||
inlineFragment fragment
|
||||
selection (Full.Field alias name arguments' directives' selections) =
|
||||
maybe (Left mempty) (Right . Core.SelectionField) <$> do
|
||||
fieldArguments <- arguments arguments'
|
||||
fieldSelections <- appendSelection selections
|
||||
fieldDirectives <- Directive.selection <$> directives directives'
|
||||
let field' = Core.Field alias name fieldArguments fieldSelections
|
||||
pure $ field' <$ fieldDirectives
|
||||
selection (Full.FragmentSpread name directives') =
|
||||
maybe (Left mempty) (Right . Core.SelectionFragment) <$> do
|
||||
spreadDirectives <- Directive.selection <$> directives directives'
|
||||
fragments' <- gets fragments
|
||||
fragment <- maybe lookupDefinition liftJust (HashMap.lookup name fragments')
|
||||
pure $ fragment <$ spreadDirectives
|
||||
where
|
||||
lookupDefinition = do
|
||||
fragmentDefinitions' <- gets fragmentDefinitions
|
||||
found <- lift . lift $ HashMap.lookup name fragmentDefinitions'
|
||||
fragmentDefinition found
|
||||
selection (Full.InlineFragment type' directives' selections) = do
|
||||
fragmentDirectives <- Directive.selection <$> directives directives'
|
||||
case fragmentDirectives of
|
||||
Nothing -> pure $ Left mempty
|
||||
_ -> do
|
||||
fragmentSelectionSet <- appendSelection selections
|
||||
pure $ maybe Left selectionFragment type' fragmentSelectionSet
|
||||
where
|
||||
selectionFragment typeName = Right
|
||||
. Core.SelectionFragment
|
||||
. Core.Fragment typeName
|
||||
|
||||
appendSelection ::
|
||||
Traversable t =>
|
||||
|
@ -104,33 +127,6 @@ collectFragments = do
|
|||
_ <- fragmentDefinition nextValue
|
||||
collectFragments
|
||||
|
||||
inlineFragment ::
|
||||
Full.InlineFragment ->
|
||||
TransformT (Either (Seq Core.Selection) Core.Selection)
|
||||
inlineFragment (Full.InlineFragment type' directives' selectionSet) = do
|
||||
fragmentDirectives <- Directive.selection <$> directives directives'
|
||||
case fragmentDirectives of
|
||||
Nothing -> pure $ Left mempty
|
||||
_ -> do
|
||||
fragmentSelectionSet <- appendSelection selectionSet
|
||||
pure $ maybe Left selectionFragment type' fragmentSelectionSet
|
||||
where
|
||||
selectionFragment typeName = Right
|
||||
. Core.SelectionFragment
|
||||
. Core.Fragment typeName
|
||||
|
||||
fragmentSpread :: Full.FragmentSpread -> TransformT (Maybe Core.Fragment)
|
||||
fragmentSpread (Full.FragmentSpread name directives') = do
|
||||
spreadDirectives <- Directive.selection <$> directives directives'
|
||||
fragments' <- gets fragments
|
||||
fragment <- maybe lookupDefinition liftJust (HashMap.lookup name fragments')
|
||||
pure $ fragment <$ spreadDirectives
|
||||
where
|
||||
lookupDefinition = do
|
||||
fragmentDefinitions' <- gets fragmentDefinitions
|
||||
found <- lift . lift $ HashMap.lookup name fragmentDefinitions'
|
||||
fragmentDefinition found
|
||||
|
||||
fragmentDefinition ::
|
||||
Full.FragmentDefinition ->
|
||||
TransformT Core.Fragment
|
||||
|
@ -147,28 +143,15 @@ fragmentDefinition (Full.FragmentDefinition name type' _ selections) = do
|
|||
let newFragments = HashMap.insert name newValue fragments'
|
||||
in Replacement newFragments fragmentDefinitions'
|
||||
|
||||
field :: Full.Field -> TransformT (Maybe Core.Field)
|
||||
field (Full.Field alias name arguments' directives' selections) = do
|
||||
fieldArguments <- traverse argument arguments'
|
||||
fieldSelections <- appendSelection selections
|
||||
fieldDirectives <- Directive.selection <$> directives directives'
|
||||
let field' = Core.Field alias name fieldArguments fieldSelections
|
||||
pure $ field' <$ fieldDirectives
|
||||
|
||||
arguments :: [Full.Argument] -> TransformT Core.Arguments
|
||||
arguments = fmap Core.Arguments . foldM go HashMap.empty
|
||||
where
|
||||
go arguments' argument' = do
|
||||
(Core.Argument name value') <- argument argument'
|
||||
return $ HashMap.insert name value' arguments'
|
||||
|
||||
argument :: Full.Argument -> TransformT Core.Argument
|
||||
argument (Full.Argument n v) = Core.Argument n <$> value v
|
||||
go arguments' (Full.Argument name value') = do
|
||||
substitutedValue <- value value'
|
||||
return $ HashMap.insert name substitutedValue arguments'
|
||||
|
||||
value :: Full.Value -> TransformT Core.Value
|
||||
value (Full.Variable n) = do
|
||||
substitute' <- lift ask
|
||||
lift . lift $ substitute' n
|
||||
value (Full.Variable name) = lift (asks $ HashMap.lookup name) >>= lift . lift
|
||||
value (Full.Int i) = pure $ Core.Int i
|
||||
value (Full.Float f) = pure $ Core.Float f
|
||||
value (Full.String x) = pure $ Core.String x
|
||||
|
|
|
@ -3,28 +3,23 @@
|
|||
-- | This module provides a representation of a @GraphQL@ Schema in addition to
|
||||
-- functions for defining and manipulating schemas.
|
||||
module Language.GraphQL.Schema
|
||||
( Resolver
|
||||
( Resolver(..)
|
||||
, Subs
|
||||
, object
|
||||
, objectA
|
||||
, scalar
|
||||
, scalarA
|
||||
, resolve
|
||||
, resolversToMap
|
||||
, scalar
|
||||
, wrappedObject
|
||||
, wrappedObjectA
|
||||
, wrappedScalar
|
||||
, wrappedScalarA
|
||||
-- * AST Reexports
|
||||
, Field
|
||||
, Argument(..)
|
||||
, Value(..)
|
||||
) where
|
||||
|
||||
import Control.Monad.IO.Class (MonadIO(..))
|
||||
import Control.Monad.Trans.Class (lift)
|
||||
import Control.Monad.Trans.Except (runExceptT)
|
||||
import Control.Monad.Trans.Reader (runReaderT)
|
||||
import Data.Foldable (find, fold)
|
||||
import Data.Foldable (fold, toList)
|
||||
import Data.Maybe (fromMaybe)
|
||||
import qualified Data.Aeson as Aeson
|
||||
import Data.HashMap.Strict (HashMap)
|
||||
|
@ -38,81 +33,80 @@ import Language.GraphQL.Trans
|
|||
import qualified Language.GraphQL.Type as Type
|
||||
|
||||
-- | Resolves a 'Field' into an @Aeson.@'Data.Aeson.Types.Object' with error
|
||||
-- information (if an error has occurred). @m@ is usually expected to be an
|
||||
-- instance of 'MonadIO'.
|
||||
-- information (if an error has occurred). @m@ is an arbitrary monad, usually
|
||||
-- 'IO'.
|
||||
data Resolver m = Resolver
|
||||
Text -- ^ Name
|
||||
(Field -> CollectErrsT m Aeson.Object) -- ^ Resolver
|
||||
|
||||
-- | Variable substitution function.
|
||||
type Subs = Name -> Maybe Value
|
||||
-- | Converts resolvers to a map.
|
||||
resolversToMap
|
||||
:: (Foldable f, Functor f)
|
||||
=> f (Resolver m)
|
||||
-> HashMap Text (Field -> CollectErrsT m Aeson.Object)
|
||||
resolversToMap = HashMap.fromList . toList . fmap toKV
|
||||
where
|
||||
toKV (Resolver name f) = (name, f)
|
||||
|
||||
-- | Contains variables for the query. The key of the map is a variable name,
|
||||
-- and the value is the variable value.
|
||||
type Subs = HashMap Name Value
|
||||
|
||||
-- | Create a new 'Resolver' with the given 'Name' from the given 'Resolver's.
|
||||
object :: MonadIO m => Name -> ActionT m [Resolver m] -> Resolver m
|
||||
object name = objectA name . const
|
||||
|
||||
-- | Like 'object' but also taking 'Argument's.
|
||||
objectA :: MonadIO m
|
||||
=> Name -> ([Argument] -> ActionT m [Resolver m]) -> Resolver m
|
||||
objectA name f = Resolver name $ resolveFieldValue f resolveRight
|
||||
object :: Monad m => Name -> ActionT m [Resolver m] -> Resolver m
|
||||
object name f = Resolver name $ resolveFieldValue f resolveRight
|
||||
where
|
||||
resolveRight fld@(Field _ _ _ flds) resolver = withField (resolve resolver flds) fld
|
||||
|
||||
-- | Like 'object' but also taking 'Argument's and can be null or a list of objects.
|
||||
wrappedObjectA :: MonadIO m
|
||||
=> Name -> ([Argument] -> ActionT m (Type.Wrapping [Resolver m])) -> Resolver m
|
||||
wrappedObjectA name f = Resolver name $ resolveFieldValue f resolveRight
|
||||
where
|
||||
resolveRight fld@(Field _ _ _ sels) resolver
|
||||
= withField (traverse (`resolve` sels) resolver) fld
|
||||
resolveRight fld@(Field _ _ _ flds) resolver
|
||||
= withField (resolve (resolversToMap resolver) flds) fld
|
||||
|
||||
-- | Like 'object' but can be null or a list of objects.
|
||||
wrappedObject :: MonadIO m
|
||||
=> Name -> ActionT m (Type.Wrapping [Resolver m]) -> Resolver m
|
||||
wrappedObject name = wrappedObjectA name . const
|
||||
wrappedObject ::
|
||||
Monad m =>
|
||||
Name ->
|
||||
ActionT m (Type.Wrapping [Resolver m]) ->
|
||||
Resolver m
|
||||
wrappedObject name f = Resolver name $ resolveFieldValue f resolveRight
|
||||
where
|
||||
resolveRight fld@(Field _ _ _ sels) resolver
|
||||
= withField (traverse (resolveMap sels) resolver) fld
|
||||
resolveMap = flip (resolve . resolversToMap)
|
||||
|
||||
-- | A scalar represents a primitive value, like a string or an integer.
|
||||
scalar :: (MonadIO m, Aeson.ToJSON a) => Name -> ActionT m a -> Resolver m
|
||||
scalar name = scalarA name . const
|
||||
|
||||
-- | Like 'scalar' but also taking 'Argument's.
|
||||
scalarA :: (MonadIO m, Aeson.ToJSON a)
|
||||
=> Name -> ([Argument] -> ActionT m a) -> Resolver m
|
||||
scalarA name f = Resolver name $ resolveFieldValue f resolveRight
|
||||
scalar :: (Monad m, Aeson.ToJSON a) => Name -> ActionT m a -> Resolver m
|
||||
scalar name f = Resolver name $ resolveFieldValue f resolveRight
|
||||
where
|
||||
resolveRight fld result = withField (return result) fld
|
||||
|
||||
-- | Like 'scalar' but also taking 'Argument's and can be null or a list of scalars.
|
||||
wrappedScalarA :: (MonadIO m, Aeson.ToJSON a)
|
||||
=> Name -> ([Argument] -> ActionT m (Type.Wrapping a)) -> Resolver m
|
||||
wrappedScalarA name f = Resolver name $ resolveFieldValue f resolveRight
|
||||
-- | Like 'scalar' but can be null or a list of scalars.
|
||||
wrappedScalar ::
|
||||
(Monad m, Aeson.ToJSON a) =>
|
||||
Name ->
|
||||
ActionT m (Type.Wrapping a) ->
|
||||
Resolver m
|
||||
wrappedScalar name f = Resolver name $ resolveFieldValue f resolveRight
|
||||
where
|
||||
resolveRight fld (Type.Named result) = withField (return result) fld
|
||||
resolveRight fld Type.Null
|
||||
= return $ HashMap.singleton (aliasOrName fld) Aeson.Null
|
||||
resolveRight fld (Type.List result) = withField (return result) fld
|
||||
|
||||
-- | Like 'scalar' but can be null or a list of scalars.
|
||||
wrappedScalar :: (MonadIO m, Aeson.ToJSON a)
|
||||
=> Name -> ActionT m (Type.Wrapping a) -> Resolver m
|
||||
wrappedScalar name = wrappedScalarA name . const
|
||||
|
||||
resolveFieldValue :: MonadIO m
|
||||
=> ([Argument] -> ActionT m a)
|
||||
-> (Field -> a -> CollectErrsT m (HashMap Text Aeson.Value))
|
||||
-> Field
|
||||
-> CollectErrsT m (HashMap Text Aeson.Value)
|
||||
resolveFieldValue ::
|
||||
Monad m =>
|
||||
ActionT m a ->
|
||||
(Field -> a -> CollectErrsT m Aeson.Object) ->
|
||||
Field ->
|
||||
CollectErrsT m (HashMap Text Aeson.Value)
|
||||
resolveFieldValue f resolveRight fld@(Field _ _ args _) = do
|
||||
result <- lift $ reader . runExceptT . runActionT $ f args
|
||||
result <- lift $ reader . runExceptT . runActionT $ f
|
||||
either resolveLeft (resolveRight fld) result
|
||||
where
|
||||
reader = flip runReaderT $ Context mempty
|
||||
reader = flip runReaderT $ Context {arguments=args}
|
||||
resolveLeft err = do
|
||||
_ <- addErrMsg err
|
||||
return $ HashMap.singleton (aliasOrName fld) Aeson.Null
|
||||
|
||||
-- | Helper function to facilitate 'Argument' handling.
|
||||
withField :: (MonadIO m, Aeson.ToJSON a)
|
||||
-- | Helper function to facilitate error handling and result emitting.
|
||||
withField :: (Monad m, Aeson.ToJSON a)
|
||||
=> CollectErrsT m a -> Field -> CollectErrsT m (HashMap Text Aeson.Value)
|
||||
withField v fld
|
||||
= HashMap.singleton (aliasOrName fld) . Aeson.toJSON <$> runAppendErrs v
|
||||
|
@ -120,23 +114,22 @@ withField v fld
|
|||
-- | Takes a list of 'Resolver's and a list of 'Field's and applies each
|
||||
-- 'Resolver' to each 'Field'. Resolves into a value containing the
|
||||
-- resolved 'Field', or a null value and error information.
|
||||
resolve :: MonadIO m
|
||||
=> [Resolver m] -> Seq Selection -> CollectErrsT m Aeson.Value
|
||||
resolve :: Monad m
|
||||
=> HashMap Text (Field -> CollectErrsT m Aeson.Object)
|
||||
-> Seq Selection
|
||||
-> CollectErrsT m Aeson.Value
|
||||
resolve resolvers = fmap (Aeson.toJSON . fold) . traverse tryResolvers
|
||||
where
|
||||
resolveTypeName (Resolver "__typename" f) = do
|
||||
resolveTypeName f = do
|
||||
value <- f $ Field Nothing "__typename" mempty mempty
|
||||
return $ HashMap.lookupDefault "" "__typename" value
|
||||
resolveTypeName _ = return ""
|
||||
tryResolvers (SelectionField fld@(Field _ name _ _))
|
||||
= maybe (errmsg fld) (tryResolver fld) $ find (compareResolvers name) resolvers
|
||||
= fromMaybe (errmsg fld) $ HashMap.lookup name resolvers <*> Just fld
|
||||
tryResolvers (SelectionFragment (Fragment typeCondition selections')) = do
|
||||
that <- traverse resolveTypeName (find (compareResolvers "__typename") resolvers)
|
||||
that <- traverse resolveTypeName $ HashMap.lookup "__typename" resolvers
|
||||
if maybe True (Aeson.String typeCondition ==) that
|
||||
then fmap fold . traverse tryResolvers $ selections'
|
||||
else return mempty
|
||||
compareResolvers name (Resolver name' _) = name == name'
|
||||
tryResolver fld (Resolver _ resolver) = resolver fld
|
||||
errmsg fld@(Field _ name _ _) = do
|
||||
addErrMsg $ T.unwords ["field", name, "not resolved."]
|
||||
return $ HashMap.singleton (aliasOrName fld) Aeson.Null
|
||||
|
|
|
@ -1,7 +1,8 @@
|
|||
-- | Monad transformer stack used by the @GraphQL@ resolvers.
|
||||
module Language.GraphQL.Trans
|
||||
( ActionT(..)
|
||||
, Context(Context)
|
||||
, Context(..)
|
||||
, argument
|
||||
) where
|
||||
|
||||
import Control.Applicative (Alternative(..))
|
||||
|
@ -9,13 +10,17 @@ import Control.Monad (MonadPlus(..))
|
|||
import Control.Monad.IO.Class (MonadIO(..))
|
||||
import Control.Monad.Trans.Class (MonadTrans(..))
|
||||
import Control.Monad.Trans.Except (ExceptT)
|
||||
import Control.Monad.Trans.Reader (ReaderT)
|
||||
import Data.HashMap.Strict (HashMap)
|
||||
import Control.Monad.Trans.Reader (ReaderT, asks)
|
||||
import qualified Data.HashMap.Strict as HashMap
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Data.Text (Text)
|
||||
import Language.GraphQL.AST.Core (Name, Value)
|
||||
import Language.GraphQL.AST.Core
|
||||
import Prelude hiding (lookup)
|
||||
|
||||
-- | Resolution context holds resolver arguments.
|
||||
newtype Context = Context (HashMap Name Value)
|
||||
newtype Context = Context
|
||||
{ arguments :: Arguments
|
||||
}
|
||||
|
||||
-- | Monad transformer stack used by the resolvers to provide error handling
|
||||
-- and resolution context (resolver arguments).
|
||||
|
@ -47,3 +52,13 @@ instance Monad m => Alternative (ActionT m) where
|
|||
instance Monad m => MonadPlus (ActionT m) where
|
||||
mzero = empty
|
||||
mplus = (<|>)
|
||||
|
||||
-- | Retrieves an argument by its name. If the argument with this name couldn't
|
||||
-- be found, returns 'Value.Null' (i.e. the argument is assumed to
|
||||
-- be optional then).
|
||||
argument :: Monad m => Name -> ActionT m Value
|
||||
argument argumentName = do
|
||||
argumentValue <- ActionT $ lift $ asks $ lookup . arguments
|
||||
pure $ fromMaybe Null argumentValue
|
||||
where
|
||||
lookup (Arguments argumentMap) = HashMap.lookup argumentName argumentMap
|
||||
|
|
|
@ -1,4 +1,4 @@
|
|||
resolver: lts-14.18
|
||||
resolver: lts-15.12
|
||||
|
||||
packages:
|
||||
- .
|
||||
|
|
|
@ -6,37 +6,124 @@ module Language.GraphQL.AST.EncoderSpec
|
|||
|
||||
import Language.GraphQL.AST
|
||||
import Language.GraphQL.AST.Encoder
|
||||
import Test.Hspec (Spec, context, describe, it, shouldBe)
|
||||
import Test.Hspec (Spec, context, describe, it, shouldBe, shouldStartWith, shouldEndWith, shouldNotContain)
|
||||
import Test.QuickCheck (choose, oneof, forAll)
|
||||
import Text.RawString.QQ (r)
|
||||
import Data.Text.Lazy (cons, toStrict, unpack)
|
||||
|
||||
spec :: Spec
|
||||
spec = do
|
||||
describe "value" $ do
|
||||
context "null value" $ do
|
||||
let testNull formatter = value formatter Null `shouldBe` "null"
|
||||
it "minified" $ testNull minified
|
||||
it "pretty" $ testNull pretty
|
||||
|
||||
context "minified" $ do
|
||||
it "escapes \\" $
|
||||
value minified (String "\\") `shouldBe` "\"\\\\\""
|
||||
it "escapes quotes" $
|
||||
it "escapes double quotes" $
|
||||
value minified (String "\"") `shouldBe` "\"\\\"\""
|
||||
it "escapes \\f" $
|
||||
value minified (String "\f") `shouldBe` "\"\\f\""
|
||||
it "escapes \\n" $
|
||||
value minified (String "\n") `shouldBe` "\"\\n\""
|
||||
it "escapes \\r" $
|
||||
value minified (String "\r") `shouldBe` "\"\\r\""
|
||||
it "escapes \\t" $
|
||||
value minified (String "\t") `shouldBe` "\"\\t\""
|
||||
it "escapes backspace" $
|
||||
value minified (String "a\bc") `shouldBe` "\"a\\bc\""
|
||||
it "escapes Unicode" $
|
||||
value minified (String "\0") `shouldBe` "\"\\u0000\""
|
||||
context "escapes Unicode for chars less than 0010" $ do
|
||||
it "Null" $ value minified (String "\x0000") `shouldBe` "\"\\u0000\""
|
||||
it "bell" $ value minified (String "\x0007") `shouldBe` "\"\\u0007\""
|
||||
context "escapes Unicode for char less than 0020" $ do
|
||||
it "DLE" $ value minified (String "\x0010") `shouldBe` "\"\\u0010\""
|
||||
it "EM" $ value minified (String "\x0019") `shouldBe` "\"\\u0019\""
|
||||
context "encodes without escape" $ do
|
||||
it "space" $ value minified (String "\x0020") `shouldBe` "\" \""
|
||||
it "~" $ value minified (String "\x007E") `shouldBe` "\"~\""
|
||||
|
||||
context "pretty" $ do
|
||||
it "uses strings for short string values" $
|
||||
value pretty (String "Short text") `shouldBe` "\"Short text\""
|
||||
it "uses block strings for text with new lines" $
|
||||
it "uses block strings for text with new lines, with newline symbol" $
|
||||
value pretty (String "Line 1\nLine 2")
|
||||
`shouldBe` "\"\"\"\n Line 1\n Line 2\n\"\"\""
|
||||
it "escapes \\ in short strings" $
|
||||
value pretty (String "\\") `shouldBe` "\"\\\\\""
|
||||
`shouldBe` [r|"""
|
||||
Line 1
|
||||
Line 2
|
||||
"""|]
|
||||
it "uses block strings for text with new lines, with CR symbol" $
|
||||
value pretty (String "Line 1\rLine 2")
|
||||
`shouldBe` [r|"""
|
||||
Line 1
|
||||
Line 2
|
||||
"""|]
|
||||
it "uses block strings for text with new lines, with CR symbol followed by newline" $
|
||||
value pretty (String "Line 1\r\nLine 2")
|
||||
`shouldBe` [r|"""
|
||||
Line 1
|
||||
Line 2
|
||||
"""|]
|
||||
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'
|
||||
]
|
||||
|
||||
forAll genNotAllowedSymbol $ \x -> do
|
||||
let
|
||||
rawValue = "Short \n" <> cons x "text"
|
||||
encoded = value pretty (String $ toStrict rawValue)
|
||||
shouldStartWith (unpack encoded) "\""
|
||||
shouldEndWith (unpack encoded) "\""
|
||||
shouldNotContain (unpack encoded) "\"\"\""
|
||||
|
||||
it "Hello world" $ value pretty (String "Hello,\n World!\n\nYours,\n GraphQL.")
|
||||
`shouldBe` [r|"""
|
||||
Hello,
|
||||
World!
|
||||
|
||||
Yours,
|
||||
GraphQL.
|
||||
"""|]
|
||||
|
||||
it "has only newlines" $ value pretty (String "\n") `shouldBe` [r|"""
|
||||
|
||||
|
||||
"""|]
|
||||
it "has newlines and one symbol at the begining" $
|
||||
value pretty (String "a\n\n") `shouldBe` [r|"""
|
||||
a
|
||||
|
||||
|
||||
"""|]
|
||||
it "has newlines and one symbol at the end" $
|
||||
value pretty (String "\n\na") `shouldBe` [r|"""
|
||||
|
||||
|
||||
a
|
||||
"""|]
|
||||
it "has newlines and one symbol in the middle" $
|
||||
value pretty (String "\na\n") `shouldBe` [r|"""
|
||||
|
||||
a
|
||||
|
||||
"""|]
|
||||
it "skip trailing whitespaces" $ value pretty (String " Short\ntext ")
|
||||
`shouldBe` [r|"""
|
||||
Short
|
||||
text
|
||||
"""|]
|
||||
|
||||
describe "definition" $
|
||||
it "indents block strings in arguments" $
|
||||
let arguments = [Argument "message" (String "line1\nline2")]
|
||||
field = Field Nothing "field" arguments [] []
|
||||
set = OperationSelectionSet $ pure $ SelectionField field
|
||||
operation = DefinitionOperation set
|
||||
operation = DefinitionOperation $ SelectionSet $ pure field
|
||||
in definition pretty operation `shouldBe` [r|{
|
||||
field(message: """
|
||||
line1
|
||||
|
|
|
@ -8,7 +8,7 @@ import Data.Text (Text)
|
|||
import Data.Void (Void)
|
||||
import Language.GraphQL.AST.Lexer
|
||||
import Test.Hspec (Spec, context, describe, it)
|
||||
import Test.Hspec.Megaparsec (shouldParse, shouldSucceedOn)
|
||||
import Test.Hspec.Megaparsec (shouldParse, shouldFailOn, shouldSucceedOn)
|
||||
import Text.Megaparsec (ParseErrorBundle, parse)
|
||||
import Text.RawString.QQ (r)
|
||||
|
||||
|
@ -77,7 +77,7 @@ spec = describe "Lexer" $ do
|
|||
parse spread "" "..." `shouldParse` "..."
|
||||
parse colon "" ":" `shouldParse` ":"
|
||||
parse equals "" "=" `shouldParse` "="
|
||||
parse at "" "@" `shouldParse` '@'
|
||||
parse at "" "@" `shouldParse` "@"
|
||||
runBetween brackets `shouldSucceedOn` "[]"
|
||||
runBetween braces `shouldSucceedOn` "{}"
|
||||
parse pipe "" "|" `shouldParse` "|"
|
||||
|
@ -87,6 +87,13 @@ spec = describe "Lexer" $ do
|
|||
parse blockString "" [r|""""""|] `shouldParse` ""
|
||||
it "lexes ampersand" $
|
||||
parse amp "" "&" `shouldParse` "&"
|
||||
it "lexes schema extensions" $
|
||||
parseExtend "schema" `shouldSucceedOn` "extend schema"
|
||||
it "fails if the given token doesn't match" $
|
||||
parseExtend "schema" `shouldFailOn` "extend shema"
|
||||
|
||||
parseExtend :: Text -> (Text -> Either (ParseErrorBundle Text Void) ())
|
||||
parseExtend extension = parse (extend extension "" $ pure $ pure ()) ""
|
||||
|
||||
runBetween :: (Parser () -> Parser ()) -> Text -> Either (ParseErrorBundle Text Void) ()
|
||||
runBetween parser = parse (parser $ pure ()) ""
|
||||
|
|
|
@ -4,9 +4,11 @@ module Language.GraphQL.AST.ParserSpec
|
|||
( spec
|
||||
) where
|
||||
|
||||
import Data.List.NonEmpty (NonEmpty(..))
|
||||
import Language.GraphQL.AST.Document
|
||||
import Language.GraphQL.AST.Parser
|
||||
import Test.Hspec (Spec, describe, it)
|
||||
import Test.Hspec.Megaparsec (shouldSucceedOn)
|
||||
import Test.Hspec.Megaparsec (shouldParse, shouldSucceedOn)
|
||||
import Text.Megaparsec (parse)
|
||||
import Text.RawString.QQ (r)
|
||||
|
||||
|
@ -28,17 +30,115 @@ spec = describe "Parser" $ do
|
|||
it "accepts two required arguments" $
|
||||
parse document "" `shouldSucceedOn` [r|
|
||||
mutation auth($username: String!, $password: String!){
|
||||
test
|
||||
test
|
||||
}|]
|
||||
|
||||
it "accepts two string arguments" $
|
||||
parse document "" `shouldSucceedOn` [r|
|
||||
mutation auth{
|
||||
test(username: "username", password: "password")
|
||||
test(username: "username", password: "password")
|
||||
}|]
|
||||
|
||||
it "accepts two block string arguments" $
|
||||
parse document "" `shouldSucceedOn` [r|
|
||||
mutation auth{
|
||||
test(username: """username""", password: """password""")
|
||||
test(username: """username""", password: """password""")
|
||||
}|]
|
||||
|
||||
it "parses minimal schema definition" $
|
||||
parse document "" `shouldSucceedOn` [r|schema { query: Query }|]
|
||||
|
||||
it "parses minimal scalar definition" $
|
||||
parse document "" `shouldSucceedOn` [r|scalar Time|]
|
||||
|
||||
it "parses ImplementsInterfaces" $
|
||||
parse document "" `shouldSucceedOn` [r|
|
||||
type Person implements NamedEntity & ValuedEntity {
|
||||
name: String
|
||||
}
|
||||
|]
|
||||
|
||||
it "parses a type without ImplementsInterfaces" $
|
||||
parse document "" `shouldSucceedOn` [r|
|
||||
type Person {
|
||||
name: String
|
||||
}
|
||||
|]
|
||||
|
||||
it "parses ArgumentsDefinition in an ObjectDefinition" $
|
||||
parse document "" `shouldSucceedOn` [r|
|
||||
type Person {
|
||||
name(first: String, last: String): String
|
||||
}
|
||||
|]
|
||||
|
||||
it "parses minimal union type definition" $
|
||||
parse document "" `shouldSucceedOn` [r|
|
||||
union SearchResult = Photo | Person
|
||||
|]
|
||||
|
||||
it "parses minimal interface type definition" $
|
||||
parse document "" `shouldSucceedOn` [r|
|
||||
interface NamedEntity {
|
||||
name: String
|
||||
}
|
||||
|]
|
||||
|
||||
it "parses minimal enum type definition" $
|
||||
parse document "" `shouldSucceedOn` [r|
|
||||
enum Direction {
|
||||
NORTH
|
||||
EAST
|
||||
SOUTH
|
||||
WEST
|
||||
}
|
||||
|]
|
||||
|
||||
it "parses minimal enum type definition" $
|
||||
parse document "" `shouldSucceedOn` [r|
|
||||
enum Direction {
|
||||
NORTH
|
||||
EAST
|
||||
SOUTH
|
||||
WEST
|
||||
}
|
||||
|]
|
||||
|
||||
it "parses minimal input object type definition" $
|
||||
parse document "" `shouldSucceedOn` [r|
|
||||
input Point2D {
|
||||
x: Float
|
||||
y: Float
|
||||
}
|
||||
|]
|
||||
|
||||
it "parses minimal input enum definition with an optional pipe" $
|
||||
parse document "" `shouldSucceedOn` [r|
|
||||
directive @example on
|
||||
| FIELD
|
||||
| FRAGMENT_SPREAD
|
||||
|]
|
||||
|
||||
it "parses schema extension with a new directive" $
|
||||
parse document "" `shouldSucceedOn`[r|
|
||||
extend schema @newDirective
|
||||
|]
|
||||
|
||||
it "parses schema extension with an operation type definition" $
|
||||
parse document "" `shouldSucceedOn` [r|extend schema { query: Query }|]
|
||||
|
||||
it "parses schema extension with an operation type and directive" $
|
||||
let newDirective = Directive "newDirective" []
|
||||
testSchemaExtension = TypeSystemExtension
|
||||
$ SchemaExtension
|
||||
$ SchemaOperationExtension [newDirective]
|
||||
$ OperationTypeDefinition Query "Query" :| []
|
||||
query = [r|extend schema @newDirective { query: Query }|]
|
||||
in parse document "" query `shouldParse` (testSchemaExtension :| [])
|
||||
|
||||
it "parses an object extension" $
|
||||
parse document "" `shouldSucceedOn` [r|
|
||||
extend type Story {
|
||||
isHiddenLocally: Boolean
|
||||
}
|
||||
|]
|
|
@ -5,14 +5,18 @@ module Test.DirectiveSpec
|
|||
) where
|
||||
|
||||
import Data.Aeson (Value, object, (.=))
|
||||
import Data.HashMap.Strict (HashMap)
|
||||
import qualified Data.HashMap.Strict as HashMap
|
||||
import Data.List.NonEmpty (NonEmpty(..))
|
||||
import Data.Text (Text)
|
||||
import Language.GraphQL
|
||||
import qualified Language.GraphQL.Schema as Schema
|
||||
import Test.Hspec (Spec, describe, it, shouldBe)
|
||||
import Text.RawString.QQ (r)
|
||||
|
||||
experimentalResolver :: Schema.Resolver IO
|
||||
experimentalResolver = Schema.scalar "experimentalField" $ pure (5 :: Int)
|
||||
experimentalResolver :: HashMap Text (NonEmpty (Schema.Resolver IO))
|
||||
experimentalResolver = HashMap.singleton "Query"
|
||||
$ Schema.scalar "experimentalField" (pure (5 :: Int)) :| []
|
||||
|
||||
emptyObject :: Value
|
||||
emptyObject = object
|
||||
|
@ -29,7 +33,7 @@ spec =
|
|||
}
|
||||
|]
|
||||
|
||||
actual <- graphql (experimentalResolver :| []) query
|
||||
actual <- graphql experimentalResolver query
|
||||
actual `shouldBe` emptyObject
|
||||
|
||||
it "should not skip fields if @skip is false" $ do
|
||||
|
@ -44,7 +48,7 @@ spec =
|
|||
]
|
||||
]
|
||||
|
||||
actual <- graphql (experimentalResolver :| []) query
|
||||
actual <- graphql experimentalResolver query
|
||||
actual `shouldBe` expected
|
||||
|
||||
it "should skip fields if @include is false" $ do
|
||||
|
@ -54,7 +58,7 @@ spec =
|
|||
}
|
||||
|]
|
||||
|
||||
actual <- graphql (experimentalResolver :| []) query
|
||||
actual <- graphql experimentalResolver query
|
||||
actual `shouldBe` emptyObject
|
||||
|
||||
it "should be able to @skip a fragment spread" $ do
|
||||
|
@ -68,7 +72,7 @@ spec =
|
|||
}
|
||||
|]
|
||||
|
||||
actual <- graphql (experimentalResolver :| []) query
|
||||
actual <- graphql experimentalResolver query
|
||||
actual `shouldBe` emptyObject
|
||||
|
||||
it "should be able to @skip an inline fragment" $ do
|
||||
|
@ -80,5 +84,5 @@ spec =
|
|||
}
|
||||
|]
|
||||
|
||||
actual <- graphql (experimentalResolver :| []) query
|
||||
actual <- graphql experimentalResolver query
|
||||
actual `shouldBe` emptyObject
|
||||
|
|
|
@ -51,7 +51,7 @@ spec :: Spec
|
|||
spec = do
|
||||
describe "Inline fragment executor" $ do
|
||||
it "chooses the first selection if the type matches" $ do
|
||||
actual <- graphql (garment "Hat" :| []) inlineQuery
|
||||
actual <- graphql (HashMap.singleton "Query" $ garment "Hat" :| []) inlineQuery
|
||||
let expected = object
|
||||
[ "data" .= object
|
||||
[ "garment" .= object
|
||||
|
@ -62,7 +62,7 @@ spec = do
|
|||
in actual `shouldBe` expected
|
||||
|
||||
it "chooses the last selection if the type matches" $ do
|
||||
actual <- graphql (garment "Shirt" :| []) inlineQuery
|
||||
actual <- graphql (HashMap.singleton "Query" $ garment "Shirt" :| []) inlineQuery
|
||||
let expected = object
|
||||
[ "data" .= object
|
||||
[ "garment" .= object
|
||||
|
@ -83,7 +83,7 @@ spec = do
|
|||
}|]
|
||||
resolvers = Schema.object "garment" $ return [circumference, size]
|
||||
|
||||
actual <- graphql (resolvers :| []) query
|
||||
actual <- graphql (HashMap.singleton "Query" $ resolvers :| []) query
|
||||
let expected = object
|
||||
[ "data" .= object
|
||||
[ "garment" .= object
|
||||
|
@ -101,7 +101,7 @@ spec = do
|
|||
}
|
||||
}|]
|
||||
|
||||
actual <- graphql (size :| []) query
|
||||
actual <- graphql (HashMap.singleton "Query" $ size :| []) query
|
||||
actual `shouldNotSatisfy` hasErrors
|
||||
|
||||
describe "Fragment spread executor" $ do
|
||||
|
@ -116,7 +116,7 @@ spec = do
|
|||
}
|
||||
|]
|
||||
|
||||
actual <- graphql (circumference :| []) query
|
||||
actual <- graphql (HashMap.singleton "Query" $ circumference :| []) query
|
||||
let expected = object
|
||||
[ "data" .= object
|
||||
[ "circumference" .= (60 :: Int)
|
||||
|
@ -141,7 +141,7 @@ spec = do
|
|||
}
|
||||
|]
|
||||
|
||||
actual <- graphql (garment "Hat" :| []) query
|
||||
actual <- graphql (HashMap.singleton "Query" $ garment "Hat" :| []) query
|
||||
let expected = object
|
||||
[ "data" .= object
|
||||
[ "garment" .= object
|
||||
|
@ -162,7 +162,7 @@ spec = do
|
|||
}
|
||||
|]
|
||||
|
||||
actual <- graphql (circumference :| []) query
|
||||
actual <- graphql (HashMap.singleton "Query" $ circumference :| []) query
|
||||
actual `shouldSatisfy` hasErrors
|
||||
|
||||
it "considers type condition" $ do
|
||||
|
@ -187,5 +187,5 @@ spec = do
|
|||
]
|
||||
]
|
||||
]
|
||||
actual <- graphql (garment "Hat" :| []) query
|
||||
actual <- graphql (HashMap.singleton "Query" $ garment "Hat" :| []) query
|
||||
actual `shouldBe` expected
|
||||
|
|
|
@ -8,7 +8,6 @@ module Test.StarWars.Data
|
|||
, getEpisode
|
||||
, getFriends
|
||||
, getHero
|
||||
, getHeroIO
|
||||
, getHuman
|
||||
, id_
|
||||
, homePlanet
|
||||
|
@ -17,11 +16,8 @@ module Test.StarWars.Data
|
|||
, typeName
|
||||
) where
|
||||
|
||||
import Data.Monoid (mempty)
|
||||
import Control.Applicative ( Alternative(..)
|
||||
, liftA2
|
||||
)
|
||||
import Control.Monad.IO.Class (MonadIO(..))
|
||||
import Data.Functor.Identity (Identity)
|
||||
import Control.Applicative (Alternative(..), liftA2)
|
||||
import Control.Monad.Trans.Except (throwE)
|
||||
import Data.Maybe (catMaybes)
|
||||
import Data.Text (Text)
|
||||
|
@ -71,7 +67,7 @@ appearsIn :: Character -> [Int]
|
|||
appearsIn (Left x) = _appearsIn . _droidChar $ x
|
||||
appearsIn (Right x) = _appearsIn . _humanChar $ x
|
||||
|
||||
secretBackstory :: MonadIO m => Character -> ActionT m Text
|
||||
secretBackstory :: Character -> ActionT Identity Text
|
||||
secretBackstory = const $ ActionT $ throwE "secretBackstory is secret."
|
||||
|
||||
typeName :: Character -> Text
|
||||
|
@ -166,9 +162,6 @@ getHero :: Int -> Character
|
|||
getHero 5 = luke
|
||||
getHero _ = artoo
|
||||
|
||||
getHeroIO :: Int -> IO Character
|
||||
getHeroIO = pure . getHero
|
||||
|
||||
getHuman :: Alternative f => ID -> f Character
|
||||
getHuman = fmap Right . getHuman'
|
||||
|
||||
|
|
|
@ -5,20 +5,15 @@ module Test.StarWars.QuerySpec
|
|||
) where
|
||||
|
||||
import qualified Data.Aeson as Aeson
|
||||
import Data.Aeson ( object
|
||||
, (.=)
|
||||
)
|
||||
import Data.Aeson ((.=))
|
||||
import Data.Functor.Identity (Identity(..))
|
||||
import qualified Data.HashMap.Strict as HashMap
|
||||
import Data.Text (Text)
|
||||
import Language.GraphQL
|
||||
import Language.GraphQL.Schema (Subs)
|
||||
import Text.RawString.QQ (r)
|
||||
import Test.Hspec.Expectations ( Expectation
|
||||
, shouldBe
|
||||
)
|
||||
import Test.Hspec ( Spec
|
||||
, describe
|
||||
, it
|
||||
)
|
||||
import Test.Hspec.Expectations (Expectation, shouldBe)
|
||||
import Test.Hspec (Spec, describe, it)
|
||||
import Test.StarWars.Schema
|
||||
|
||||
-- * Test
|
||||
|
@ -34,7 +29,11 @@ spec = describe "Star Wars Query Tests" $ do
|
|||
}
|
||||
}
|
||||
|]
|
||||
$ object [ "data" .= object ["hero" .= object ["id" .= ("2001" :: Text)]]]
|
||||
$ Aeson.object
|
||||
[ "data" .= Aeson.object
|
||||
[ "hero" .= Aeson.object ["id" .= ("2001" :: Text)]
|
||||
]
|
||||
]
|
||||
it "R2-D2 ID and friends" $ testQuery
|
||||
[r| query HeroNameAndFriendsQuery {
|
||||
hero {
|
||||
|
@ -46,14 +45,14 @@ spec = describe "Star Wars Query Tests" $ do
|
|||
}
|
||||
}
|
||||
|]
|
||||
$ object [ "data" .= object [
|
||||
"hero" .= object
|
||||
$ Aeson.object [ "data" .= Aeson.object [
|
||||
"hero" .= Aeson.object
|
||||
[ "id" .= ("2001" :: Text)
|
||||
, r2d2Name
|
||||
, "friends" .=
|
||||
[ object [lukeName]
|
||||
, object [hanName]
|
||||
, object [leiaName]
|
||||
[ Aeson.object [lukeName]
|
||||
, Aeson.object [hanName]
|
||||
, Aeson.object [leiaName]
|
||||
]
|
||||
]
|
||||
]]
|
||||
|
@ -73,37 +72,37 @@ spec = describe "Star Wars Query Tests" $ do
|
|||
}
|
||||
}
|
||||
|]
|
||||
$ object [ "data" .= object [
|
||||
"hero" .= object [
|
||||
$ Aeson.object [ "data" .= Aeson.object [
|
||||
"hero" .= Aeson.object [
|
||||
"name" .= ("R2-D2" :: Text)
|
||||
, "friends" .= [
|
||||
object [
|
||||
Aeson.object [
|
||||
"name" .= ("Luke Skywalker" :: Text)
|
||||
, "appearsIn" .= ["NEWHOPE","EMPIRE","JEDI" :: Text]
|
||||
, "friends" .= [
|
||||
object [hanName]
|
||||
, object [leiaName]
|
||||
, object [c3poName]
|
||||
, object [r2d2Name]
|
||||
Aeson.object [hanName]
|
||||
, Aeson.object [leiaName]
|
||||
, Aeson.object [c3poName]
|
||||
, Aeson.object [r2d2Name]
|
||||
]
|
||||
]
|
||||
, object [
|
||||
, Aeson.object [
|
||||
hanName
|
||||
, "appearsIn" .= [ "NEWHOPE","EMPIRE","JEDI" :: Text]
|
||||
, "friends" .= [
|
||||
object [lukeName]
|
||||
, object [leiaName]
|
||||
, object [r2d2Name]
|
||||
, "friends" .=
|
||||
[ Aeson.object [lukeName]
|
||||
, Aeson.object [leiaName]
|
||||
, Aeson.object [r2d2Name]
|
||||
]
|
||||
]
|
||||
, object [
|
||||
, Aeson.object [
|
||||
leiaName
|
||||
, "appearsIn" .= [ "NEWHOPE","EMPIRE","JEDI" :: Text]
|
||||
, "friends" .= [
|
||||
object [lukeName]
|
||||
, object [hanName]
|
||||
, object [c3poName]
|
||||
, object [r2d2Name]
|
||||
, "friends" .=
|
||||
[ Aeson.object [lukeName]
|
||||
, Aeson.object [hanName]
|
||||
, Aeson.object [c3poName]
|
||||
, Aeson.object [r2d2Name]
|
||||
]
|
||||
]
|
||||
]
|
||||
|
@ -116,40 +115,40 @@ spec = describe "Star Wars Query Tests" $ do
|
|||
}
|
||||
}
|
||||
|]
|
||||
$ object [ "data" .= object [
|
||||
"human" .= object [lukeName]
|
||||
]]
|
||||
$ Aeson.object [ "data" .= Aeson.object
|
||||
[ "human" .= Aeson.object [lukeName]
|
||||
]]
|
||||
|
||||
it "Luke ID with variable" $ testQueryParams
|
||||
(\v -> if v == "someId" then Just "1000" else Nothing)
|
||||
(HashMap.singleton "someId" "1000")
|
||||
[r| query FetchSomeIDQuery($someId: String!) {
|
||||
human(id: $someId) {
|
||||
name
|
||||
}
|
||||
}
|
||||
|]
|
||||
$ object [ "data" .= object [
|
||||
"human" .= object [lukeName]
|
||||
$ Aeson.object [ "data" .= Aeson.object [
|
||||
"human" .= Aeson.object [lukeName]
|
||||
]]
|
||||
it "Han ID with variable" $ testQueryParams
|
||||
(\v -> if v == "someId" then Just "1002" else Nothing)
|
||||
(HashMap.singleton "someId" "1002")
|
||||
[r| query FetchSomeIDQuery($someId: String!) {
|
||||
human(id: $someId) {
|
||||
name
|
||||
}
|
||||
}
|
||||
|]
|
||||
$ object [ "data" .= object [
|
||||
"human" .= object [hanName]
|
||||
$ Aeson.object [ "data" .= Aeson.object [
|
||||
"human" .= Aeson.object [hanName]
|
||||
]]
|
||||
it "Invalid ID" $ testQueryParams
|
||||
(\v -> if v == "id" then Just "Not a valid ID" else Nothing)
|
||||
(HashMap.singleton "id" "Not a valid ID")
|
||||
[r| query humanQuery($id: String!) {
|
||||
human(id: $id) {
|
||||
name
|
||||
}
|
||||
}
|
||||
|] $ object ["data" .= object ["human" .= Aeson.Null]]
|
||||
|] $ Aeson.object ["data" .= Aeson.object ["human" .= Aeson.Null]]
|
||||
it "Luke aliased" $ testQuery
|
||||
[r| query FetchLukeAliased {
|
||||
luke: human(id: "1000") {
|
||||
|
@ -157,8 +156,8 @@ spec = describe "Star Wars Query Tests" $ do
|
|||
}
|
||||
}
|
||||
|]
|
||||
$ object [ "data" .= object [
|
||||
"luke" .= object [lukeName]
|
||||
$ Aeson.object [ "data" .= Aeson.object [
|
||||
"luke" .= Aeson.object [lukeName]
|
||||
]]
|
||||
it "R2-D2 ID and friends aliased" $ testQuery
|
||||
[r| query HeroNameAndFriendsQuery {
|
||||
|
@ -171,14 +170,14 @@ spec = describe "Star Wars Query Tests" $ do
|
|||
}
|
||||
}
|
||||
|]
|
||||
$ object [ "data" .= object [
|
||||
"hero" .= object [
|
||||
$ Aeson.object [ "data" .= Aeson.object [
|
||||
"hero" .= Aeson.object [
|
||||
"id" .= ("2001" :: Text)
|
||||
, r2d2Name
|
||||
, "friends" .= [
|
||||
object ["friendName" .= ("Luke Skywalker" :: Text)]
|
||||
, object ["friendName" .= ("Han Solo" :: Text)]
|
||||
, object ["friendName" .= ("Leia Organa" :: Text)]
|
||||
, "friends" .=
|
||||
[ Aeson.object ["friendName" .= ("Luke Skywalker" :: Text)]
|
||||
, Aeson.object ["friendName" .= ("Han Solo" :: Text)]
|
||||
, Aeson.object ["friendName" .= ("Leia Organa" :: Text)]
|
||||
]
|
||||
]
|
||||
]]
|
||||
|
@ -192,9 +191,9 @@ spec = describe "Star Wars Query Tests" $ do
|
|||
}
|
||||
}
|
||||
|]
|
||||
$ object [ "data" .= object [
|
||||
"luke" .= object [lukeName]
|
||||
, "leia" .= object [leiaName]
|
||||
$ Aeson.object [ "data" .= Aeson.object
|
||||
[ "luke" .= Aeson.object [lukeName]
|
||||
, "leia" .= Aeson.object [leiaName]
|
||||
]]
|
||||
|
||||
describe "Fragments for complex queries" $ do
|
||||
|
@ -210,9 +209,9 @@ spec = describe "Star Wars Query Tests" $ do
|
|||
}
|
||||
}
|
||||
|]
|
||||
$ object [ "data" .= object [
|
||||
"luke" .= object [lukeName, tatooine]
|
||||
, "leia" .= object [leiaName, alderaan]
|
||||
$ Aeson.object [ "data" .= Aeson.object [
|
||||
"luke" .= Aeson.object [lukeName, tatooine]
|
||||
, "leia" .= Aeson.object [leiaName, alderaan]
|
||||
]]
|
||||
it "Fragment for duplicate content" $ testQuery
|
||||
[r| query UseFragment {
|
||||
|
@ -228,9 +227,9 @@ spec = describe "Star Wars Query Tests" $ do
|
|||
homePlanet
|
||||
}
|
||||
|]
|
||||
$ object [ "data" .= object [
|
||||
"luke" .= object [lukeName, tatooine]
|
||||
, "leia" .= object [leiaName, alderaan]
|
||||
$ Aeson.object [ "data" .= Aeson.object [
|
||||
"luke" .= Aeson.object [lukeName, tatooine]
|
||||
, "leia" .= Aeson.object [leiaName, alderaan]
|
||||
]]
|
||||
|
||||
describe "__typename" $ do
|
||||
|
@ -242,8 +241,11 @@ spec = describe "Star Wars Query Tests" $ do
|
|||
}
|
||||
}
|
||||
|]
|
||||
$ object ["data" .= object [
|
||||
"hero" .= object ["__typename" .= ("Droid" :: Text), r2d2Name]
|
||||
$ Aeson.object ["data" .= Aeson.object [
|
||||
"hero" .= Aeson.object
|
||||
[ "__typename" .= ("Droid" :: Text)
|
||||
, r2d2Name
|
||||
]
|
||||
]]
|
||||
it "Luke is a human" $ testQuery
|
||||
[r| query CheckTypeOfLuke {
|
||||
|
@ -253,8 +255,11 @@ spec = describe "Star Wars Query Tests" $ do
|
|||
}
|
||||
}
|
||||
|]
|
||||
$ object ["data" .= object [
|
||||
"hero" .= object ["__typename" .= ("Human" :: Text), lukeName]
|
||||
$ Aeson.object ["data" .= Aeson.object [
|
||||
"hero" .= Aeson.object
|
||||
[ "__typename" .= ("Human" :: Text)
|
||||
, lukeName
|
||||
]
|
||||
]]
|
||||
|
||||
describe "Errors in resolvers" $ do
|
||||
|
@ -267,15 +272,15 @@ spec = describe "Star Wars Query Tests" $ do
|
|||
}
|
||||
}
|
||||
|]
|
||||
$ object
|
||||
[ "data" .= object
|
||||
[ "hero" .= object
|
||||
$ Aeson.object
|
||||
[ "data" .= Aeson.object
|
||||
[ "hero" .= Aeson.object
|
||||
[ "name" .= ("R2-D2" :: Text)
|
||||
, "secretBackstory" .= Aeson.Null
|
||||
]
|
||||
]
|
||||
, "errors" .=
|
||||
[ object
|
||||
[ Aeson.object
|
||||
["message" .= ("secretBackstory is secret." :: Text)]
|
||||
]
|
||||
]
|
||||
|
@ -290,19 +295,19 @@ spec = describe "Star Wars Query Tests" $ do
|
|||
}
|
||||
}
|
||||
|]
|
||||
$ object ["data" .= object
|
||||
[ "hero" .= object
|
||||
$ Aeson.object ["data" .= Aeson.object
|
||||
[ "hero" .= Aeson.object
|
||||
[ "name" .= ("R2-D2" :: Text)
|
||||
, "friends" .=
|
||||
[ object
|
||||
[ Aeson.object
|
||||
[ "name" .= ("Luke Skywalker" :: Text)
|
||||
, "secretBackstory" .= Aeson.Null
|
||||
]
|
||||
, object
|
||||
, Aeson.object
|
||||
[ "name" .= ("Han Solo" :: Text)
|
||||
, "secretBackstory" .= Aeson.Null
|
||||
]
|
||||
, object
|
||||
, Aeson.object
|
||||
[ "name" .= ("Leia Organa" :: Text)
|
||||
, "secretBackstory" .= Aeson.Null
|
||||
]
|
||||
|
@ -310,9 +315,15 @@ spec = describe "Star Wars Query Tests" $ do
|
|||
]
|
||||
]
|
||||
, "errors" .=
|
||||
[ object ["message" .= ("secretBackstory is secret." :: Text)]
|
||||
, object ["message" .= ("secretBackstory is secret." :: Text)]
|
||||
, object ["message" .= ("secretBackstory is secret." :: Text)]
|
||||
[ Aeson.object
|
||||
[ "message" .= ("secretBackstory is secret." :: Text)
|
||||
]
|
||||
, Aeson.object
|
||||
[ "message" .= ("secretBackstory is secret." :: Text)
|
||||
]
|
||||
, Aeson.object
|
||||
[ "message" .= ("secretBackstory is secret." :: Text)
|
||||
]
|
||||
]
|
||||
]
|
||||
it "error on secretBackstory with alias" $ testQuery
|
||||
|
@ -323,15 +334,17 @@ spec = describe "Star Wars Query Tests" $ do
|
|||
}
|
||||
}
|
||||
|]
|
||||
$ object
|
||||
[ "data" .= object
|
||||
[ "mainHero" .= object
|
||||
$ Aeson.object
|
||||
[ "data" .= Aeson.object
|
||||
[ "mainHero" .= Aeson.object
|
||||
[ "name" .= ("R2-D2" :: Text)
|
||||
, "story" .= Aeson.Null
|
||||
]
|
||||
]
|
||||
, "errors" .=
|
||||
[ object ["message" .= ("secretBackstory is secret." :: Text)]
|
||||
[ Aeson.object
|
||||
[ "message" .= ("secretBackstory is secret." :: Text)
|
||||
]
|
||||
]
|
||||
]
|
||||
|
||||
|
@ -345,7 +358,8 @@ spec = describe "Star Wars Query Tests" $ do
|
|||
alderaan = "homePlanet" .= ("Alderaan" :: Text)
|
||||
|
||||
testQuery :: Text -> Aeson.Value -> Expectation
|
||||
testQuery q expected = graphql schema q >>= flip shouldBe expected
|
||||
testQuery q expected = runIdentity (graphql schema q) `shouldBe` expected
|
||||
|
||||
testQueryParams :: Subs -> Text -> Aeson.Value -> Expectation
|
||||
testQueryParams f q expected = graphqlSubs schema f q >>= flip shouldBe expected
|
||||
testQueryParams f q expected =
|
||||
runIdentity (graphqlSubs schema f q) `shouldBe` expected
|
||||
|
|
|
@ -1,4 +1,3 @@
|
|||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
module Test.StarWars.Schema
|
||||
( character
|
||||
|
@ -10,9 +9,12 @@ module Test.StarWars.Schema
|
|||
|
||||
import Control.Monad.Trans.Except (throwE)
|
||||
import Control.Monad.Trans.Class (lift)
|
||||
import Control.Monad.IO.Class (MonadIO(..))
|
||||
import Data.Functor.Identity (Identity)
|
||||
import Data.HashMap.Strict (HashMap)
|
||||
import qualified Data.HashMap.Strict as HashMap
|
||||
import Data.List.NonEmpty (NonEmpty(..))
|
||||
import Data.Maybe (catMaybes)
|
||||
import Data.Text (Text)
|
||||
import qualified Language.GraphQL.Schema as Schema
|
||||
import Language.GraphQL.Trans
|
||||
import qualified Language.GraphQL.Type as Type
|
||||
|
@ -20,32 +22,37 @@ import Test.StarWars.Data
|
|||
|
||||
-- See https://github.com/graphql/graphql-js/blob/master/src/__tests__/starWarsSchema.js
|
||||
|
||||
schema :: MonadIO m => NonEmpty (Schema.Resolver m)
|
||||
schema = hero :| [human, droid]
|
||||
schema :: HashMap Text (NonEmpty (Schema.Resolver Identity))
|
||||
schema = HashMap.singleton "Query" $ hero :| [human, droid]
|
||||
|
||||
hero :: MonadIO m => Schema.Resolver m
|
||||
hero = Schema.objectA "hero" $ \case
|
||||
[] -> character artoo
|
||||
[Schema.Argument "episode" (Schema.Enum "NEWHOPE")] -> character $ getHero 4
|
||||
[Schema.Argument "episode" (Schema.Enum "EMPIRE" )] -> character $ getHero 5
|
||||
[Schema.Argument "episode" (Schema.Enum "JEDI" )] -> character $ getHero 6
|
||||
_ -> ActionT $ throwE "Invalid arguments."
|
||||
hero :: Schema.Resolver Identity
|
||||
hero = Schema.object "hero" $ do
|
||||
episode <- argument "episode"
|
||||
character $ case episode of
|
||||
Schema.Enum "NEWHOPE" -> getHero 4
|
||||
Schema.Enum "EMPIRE" -> getHero 5
|
||||
Schema.Enum "JEDI" -> getHero 6
|
||||
_ -> artoo
|
||||
|
||||
human :: MonadIO m => Schema.Resolver m
|
||||
human = Schema.wrappedObjectA "human" $ \case
|
||||
[Schema.Argument "id" (Schema.String i)] -> do
|
||||
humanCharacter <- lift $ return $ getHuman i >>= Just
|
||||
case humanCharacter of
|
||||
Nothing -> return Type.Null
|
||||
Just e -> Type.Named <$> character e
|
||||
_ -> ActionT $ throwE "Invalid arguments."
|
||||
human :: Schema.Resolver Identity
|
||||
human = Schema.wrappedObject "human" $ do
|
||||
id' <- argument "id"
|
||||
case id' of
|
||||
Schema.String i -> do
|
||||
humanCharacter <- lift $ return $ getHuman i >>= Just
|
||||
case humanCharacter of
|
||||
Nothing -> return Type.Null
|
||||
Just e -> Type.Named <$> character e
|
||||
_ -> ActionT $ throwE "Invalid arguments."
|
||||
|
||||
droid :: MonadIO m => Schema.Resolver m
|
||||
droid = Schema.objectA "droid" $ \case
|
||||
[Schema.Argument "id" (Schema.String i)] -> character =<< liftIO (getDroid i)
|
||||
_ -> ActionT $ throwE "Invalid arguments."
|
||||
droid :: Schema.Resolver Identity
|
||||
droid = Schema.object "droid" $ do
|
||||
id' <- argument "id"
|
||||
case id' of
|
||||
Schema.String i -> character =<< getDroid i
|
||||
_ -> ActionT $ throwE "Invalid arguments."
|
||||
|
||||
character :: MonadIO m => Character -> ActionT m [Schema.Resolver m]
|
||||
character :: Character -> ActionT Identity [Schema.Resolver Identity]
|
||||
character char = return
|
||||
[ Schema.scalar "id" $ return $ id_ char
|
||||
, Schema.scalar "name" $ return $ name char
|
||||
|
|
Loading…
Reference in New Issue