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.sandbox.config
|
||||||
cabal.project.local
|
cabal.project.local
|
||||||
/graphql.cabal
|
/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.
|
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
|
## [0.6.1.0] - 2019-12-23
|
||||||
### Fixed
|
### Fixed
|
||||||
- Parsing multiple string arguments, such as
|
- Parsing multiple string arguments, such as
|
||||||
`login(username: "username", password: "password")` would fail on the comma
|
`login(username: "username", password: "password")` would fail on the comma
|
||||||
due to strings not having a space consumer.
|
due to strings not having a space consumer.
|
||||||
- Fragment spread is evaluated based on the `__typename` resolver. If the
|
- 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
|
### Added
|
||||||
- Data types for the GraphQL language.
|
- 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.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.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.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
|
Copyright 2015-2017 J. Daniel Navarro
|
||||||
|
|
||||||
All rights reserved.
|
All rights reserved.
|
||||||
|
|
|
@ -24,11 +24,18 @@ For the list of currently missing features see issues marked as
|
||||||
## Documentation
|
## Documentation
|
||||||
|
|
||||||
API documentation is available through
|
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
|
You'll also find a small tutorial with some examples under
|
||||||
[docs/tutorial](https://github.com/caraus-ecms/graphql/tree/master/docs/tutorial).
|
[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
|
## Contact
|
||||||
|
|
||||||
Suggestions, contributions and bug reports are welcome.
|
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.
|
Since this file is a literate haskell file, we start by importing some dependencies.
|
||||||
|
|
||||||
> {-# LANGUAGE OverloadedStrings #-}
|
> {-# LANGUAGE OverloadedStrings #-}
|
||||||
> {-# LANGUAGE LambdaCase #-}
|
|
||||||
> module Main where
|
> module Main where
|
||||||
>
|
>
|
||||||
> import Control.Monad.IO.Class (liftIO)
|
> import Control.Monad.IO.Class (liftIO)
|
||||||
> import Control.Monad.Trans.Except (throwE)
|
|
||||||
> import Data.Aeson (encode)
|
> import Data.Aeson (encode)
|
||||||
> import Data.ByteString.Lazy.Char8 (putStrLn)
|
> 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.List.NonEmpty (NonEmpty(..))
|
||||||
> import Data.Text (Text)
|
> import Data.Text (Text)
|
||||||
> import Data.Time (getCurrentTime)
|
> import Data.Time (getCurrentTime)
|
||||||
>
|
>
|
||||||
> import Language.GraphQL
|
> import Language.GraphQL
|
||||||
> import qualified Language.GraphQL.Schema as Schema
|
> import qualified Language.GraphQL.Schema as Schema
|
||||||
> import Language.GraphQL.Trans (ActionT(..))
|
|
||||||
>
|
>
|
||||||
> import Prelude hiding (putStrLn)
|
> import Prelude hiding (putStrLn)
|
||||||
|
|
||||||
|
@ -36,8 +35,8 @@ example from [graphql.js](https://github.com/graphql/graphql-js).
|
||||||
|
|
||||||
First we build a GraphQL schema.
|
First we build a GraphQL schema.
|
||||||
|
|
||||||
> schema1 :: NonEmpty (Schema.Resolver IO)
|
> schema1 :: HashMap Text (NonEmpty (Schema.Resolver IO))
|
||||||
> schema1 = hello :| []
|
> schema1 = HashMap.singleton "Query" $ hello :| []
|
||||||
>
|
>
|
||||||
> hello :: Schema.Resolver IO
|
> hello :: Schema.Resolver IO
|
||||||
> hello = Schema.scalar "hello" (return ("it's me" :: Text))
|
> hello = Schema.scalar "hello" (return ("it's me" :: Text))
|
||||||
|
@ -66,14 +65,13 @@ returning
|
||||||
|
|
||||||
For this example, we're going to be using time.
|
For this example, we're going to be using time.
|
||||||
|
|
||||||
> schema2 :: NonEmpty (Schema.Resolver IO)
|
> schema2 :: HashMap Text (NonEmpty (Schema.Resolver IO))
|
||||||
> schema2 = time :| []
|
> schema2 = HashMap.singleton "Query" $ time :| []
|
||||||
>
|
>
|
||||||
> time :: Schema.Resolver IO
|
> time :: Schema.Resolver IO
|
||||||
> time = Schema.scalarA "time" $ \case
|
> time = Schema.scalar "time" $ do
|
||||||
> [] -> do t <- liftIO getCurrentTime
|
> t <- liftIO getCurrentTime
|
||||||
> return $ show t
|
> return $ show t
|
||||||
> _ -> ActionT $ throwE "Invalid arguments."
|
|
||||||
|
|
||||||
This defines a simple schema with one type and one field,
|
This defines a simple schema with one type and one field,
|
||||||
which resolves to the current time.
|
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.
|
Now that we have two resolvers, we can define a schema which uses them both.
|
||||||
|
|
||||||
> schema3 :: NonEmpty (Schema.Resolver IO)
|
> schema3 :: HashMap Text (NonEmpty (Schema.Resolver IO))
|
||||||
> schema3 = hello :| [time]
|
> schema3 = HashMap.singleton "Query" $ hello :| [time]
|
||||||
>
|
>
|
||||||
> query3 :: Text
|
> query3 :: Text
|
||||||
> query3 = "query timeAndHello { time hello }"
|
> query3 = "query timeAndHello { time hello }"
|
||||||
|
|
|
@ -1,5 +1,5 @@
|
||||||
name: graphql
|
name: graphql
|
||||||
version: 0.6.1.0
|
version: 0.7.0.0
|
||||||
synopsis: Haskell GraphQL implementation
|
synopsis: Haskell GraphQL implementation
|
||||||
description:
|
description:
|
||||||
This package provides a rudimentary parser for the
|
This package provides a rudimentary parser for the
|
||||||
|
@ -8,7 +8,7 @@ maintainer: belka@caraus.de
|
||||||
github: caraus-ecms/graphql
|
github: caraus-ecms/graphql
|
||||||
category: Language
|
category: Language
|
||||||
copyright:
|
copyright:
|
||||||
- (c) 2019 Eugen Wissner
|
- (c) 2019-2020 Eugen Wissner
|
||||||
- (c) 2015-2017 J. Daniel Navarro
|
- (c) 2015-2017 J. Daniel Navarro
|
||||||
author:
|
author:
|
||||||
- Danny Navarro <j@dannynavarro.net>
|
- Danny Navarro <j@dannynavarro.net>
|
||||||
|
@ -30,6 +30,7 @@ dependencies:
|
||||||
- base >= 4.7 && < 5
|
- base >= 4.7 && < 5
|
||||||
- containers
|
- containers
|
||||||
- megaparsec
|
- megaparsec
|
||||||
|
- parser-combinators
|
||||||
- text
|
- text
|
||||||
- transformers
|
- transformers
|
||||||
- unordered-containers
|
- unordered-containers
|
||||||
|
@ -53,4 +54,5 @@ tests:
|
||||||
- hspec
|
- hspec
|
||||||
- hspec-expectations
|
- hspec-expectations
|
||||||
- hspec-megaparsec
|
- hspec-megaparsec
|
||||||
|
- QuickCheck
|
||||||
- raw-strings-qq
|
- raw-strings-qq
|
||||||
|
|
|
@ -8,7 +8,12 @@ setup() {
|
||||||
then
|
then
|
||||||
curl -L https://get.haskellstack.org/stable/linux-x86_64.tar.gz | tar xz --wildcards --strip-components=1 -C $SEMAPHORE_CACHE_DIR '*/stack'
|
curl -L https://get.haskellstack.org/stable/linux-x86_64.tar.gz | tar xz --wildcards --strip-components=1 -C $SEMAPHORE_CACHE_DIR '*/stack'
|
||||||
fi
|
fi
|
||||||
|
if [ -e "$SEMAPHORE_CACHE_DIR/graphql.cabal" ]
|
||||||
|
then
|
||||||
|
cp -a $SEMAPHORE_CACHE_DIR/graphql.cabal graphql.cabal
|
||||||
|
fi
|
||||||
$STACK --no-terminal setup
|
$STACK --no-terminal setup
|
||||||
|
cp -a graphql.cabal $SEMAPHORE_CACHE_DIR/graphql.cabal
|
||||||
}
|
}
|
||||||
|
|
||||||
setup_test() {
|
setup_test() {
|
||||||
|
|
|
@ -4,10 +4,10 @@ module Language.GraphQL
|
||||||
, graphqlSubs
|
, graphqlSubs
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Control.Monad.IO.Class (MonadIO)
|
|
||||||
import qualified Data.Aeson as Aeson
|
import qualified Data.Aeson as Aeson
|
||||||
import Data.List.NonEmpty (NonEmpty)
|
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.Error
|
||||||
import Language.GraphQL.Execute
|
import Language.GraphQL.Execute
|
||||||
import Language.GraphQL.AST.Parser
|
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
|
-- | If the text parses correctly as a @GraphQL@ query the query is
|
||||||
-- executed using the given 'Schema.Resolver's.
|
-- executed using the given 'Schema.Resolver's.
|
||||||
graphql :: MonadIO m
|
graphql :: Monad m
|
||||||
=> NonEmpty (Schema.Resolver m) -- ^ Resolvers.
|
=> HashMap Text (NonEmpty (Schema.Resolver m)) -- ^ Resolvers.
|
||||||
-> T.Text -- ^ Text representing a @GraphQL@ request document.
|
-> Text -- ^ Text representing a @GraphQL@ request document.
|
||||||
-> m Aeson.Value -- ^ Response.
|
-> 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
|
-- | 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
|
-- applied to the query and the query is then executed using to the given
|
||||||
-- 'Schema.Resolver's.
|
-- 'Schema.Resolver's.
|
||||||
graphqlSubs :: MonadIO m
|
graphqlSubs :: Monad m
|
||||||
=> NonEmpty (Schema.Resolver m) -- ^ Resolvers.
|
=> HashMap Text (NonEmpty (Schema.Resolver m)) -- ^ Resolvers.
|
||||||
-> Schema.Subs -- ^ Variable substitution function.
|
-> Schema.Subs -- ^ Variable substitution function.
|
||||||
-> T.Text -- ^ Text representing a @GraphQL@ request document.
|
-> Text -- ^ Text representing a @GraphQL@ request document.
|
||||||
-> m Aeson.Value -- ^ Response.
|
-> m Aeson.Value -- ^ Response.
|
||||||
graphqlSubs schema f
|
graphqlSubs schema f
|
||||||
= either parseError (execute schema f)
|
= either parseError (execute schema f)
|
||||||
|
|
|
@ -1,185 +1,6 @@
|
||||||
-- | This module defines an abstract syntax tree for the @GraphQL@ language based on
|
-- | Target AST for Parser.
|
||||||
-- <https://facebook.github.io/graphql/ Facebook's GraphQL Specification>.
|
|
||||||
--
|
|
||||||
-- Target AST for Parser.
|
|
||||||
module Language.GraphQL.AST
|
module Language.GraphQL.AST
|
||||||
( Alias
|
( module Language.GraphQL.AST.Document
|
||||||
, Argument(..)
|
|
||||||
, Definition(..)
|
|
||||||
, Directive(..)
|
|
||||||
, Document
|
|
||||||
, Field(..)
|
|
||||||
, FragmentDefinition(..)
|
|
||||||
, FragmentSpread(..)
|
|
||||||
, InlineFragment(..)
|
|
||||||
, Name
|
|
||||||
, NonNullType(..)
|
|
||||||
, ObjectField(..)
|
|
||||||
, OperationDefinition(..)
|
|
||||||
, OperationType(..)
|
|
||||||
, Selection(..)
|
|
||||||
, SelectionSet
|
|
||||||
, SelectionSetOpt
|
|
||||||
, Type(..)
|
|
||||||
, TypeCondition
|
|
||||||
, Value(..)
|
|
||||||
, VariableDefinition(..)
|
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Data.Int (Int32)
|
import Language.GraphQL.AST.Document
|
||||||
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)
|
|
||||||
|
|
|
@ -1,7 +1,6 @@
|
||||||
-- | This is the AST meant to be executed.
|
-- | This is the AST meant to be executed.
|
||||||
module Language.GraphQL.AST.Core
|
module Language.GraphQL.AST.Core
|
||||||
( Alias
|
( Alias
|
||||||
, Argument(..)
|
|
||||||
, Arguments(..)
|
, Arguments(..)
|
||||||
, Directive(..)
|
, Directive(..)
|
||||||
, Document
|
, Document
|
||||||
|
@ -35,16 +34,19 @@ data Operation
|
||||||
|
|
||||||
-- | Single GraphQL field.
|
-- | Single GraphQL field.
|
||||||
data Field
|
data Field
|
||||||
= Field (Maybe Alias) Name [Argument] (Seq Selection)
|
= Field (Maybe Alias) Name Arguments (Seq Selection)
|
||||||
deriving (Eq, Show)
|
deriving (Eq, Show)
|
||||||
|
|
||||||
-- | Single argument.
|
|
||||||
data Argument = Argument Name Value deriving (Eq, Show)
|
|
||||||
|
|
||||||
-- | Argument list.
|
-- | Argument list.
|
||||||
newtype Arguments = Arguments (HashMap Name Value)
|
newtype Arguments = Arguments (HashMap Name Value)
|
||||||
deriving (Eq, Show)
|
deriving (Eq, Show)
|
||||||
|
|
||||||
|
instance Semigroup Arguments where
|
||||||
|
(Arguments x) <> (Arguments y) = Arguments $ x <> y
|
||||||
|
|
||||||
|
instance Monoid Arguments where
|
||||||
|
mempty = Arguments mempty
|
||||||
|
|
||||||
-- | Directive.
|
-- | Directive.
|
||||||
data Directive = Directive Name Arguments
|
data Directive = Directive Name Arguments
|
||||||
deriving (Eq, Show)
|
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.Char (ord)
|
||||||
import Data.Foldable (fold)
|
import Data.Foldable (fold)
|
||||||
import Data.Monoid ((<>))
|
|
||||||
import qualified Data.List.NonEmpty as NonEmpty
|
import qualified Data.List.NonEmpty as NonEmpty
|
||||||
import Data.Text (Text)
|
import Data.Text (Text)
|
||||||
import qualified Data.Text as 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.Int (decimal, hexadecimal)
|
||||||
import Data.Text.Lazy.Builder.RealFloat (realFloat)
|
import Data.Text.Lazy.Builder.RealFloat (realFloat)
|
||||||
import qualified Language.GraphQL.AST as Full
|
import qualified Language.GraphQL.AST as Full
|
||||||
|
import Language.GraphQL.AST.Document
|
||||||
|
|
||||||
-- | Instructs the encoder whether the GraphQL document should be minified or
|
-- | Instructs the encoder whether the GraphQL document should be minified or
|
||||||
-- pretty printed.
|
-- pretty printed.
|
||||||
|
@ -43,16 +43,18 @@ pretty = Pretty 0
|
||||||
minified :: Formatter
|
minified :: Formatter
|
||||||
minified = Minified
|
minified = Minified
|
||||||
|
|
||||||
-- | Converts a 'Full.Document' into a string.
|
-- | Converts a Document' into a string.
|
||||||
document :: Formatter -> Full.Document -> Lazy.Text
|
document :: Formatter -> Document -> Lazy.Text
|
||||||
document formatter defs
|
document formatter defs
|
||||||
| Pretty _ <- formatter = Lazy.Text.intercalate "\n" encodeDocument
|
| Pretty _ <- formatter = Lazy.Text.intercalate "\n" encodeDocument
|
||||||
| Minified <-formatter = Lazy.Text.snoc (mconcat encodeDocument) '\n'
|
| Minified <-formatter = Lazy.Text.snoc (mconcat encodeDocument) '\n'
|
||||||
where
|
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.
|
-- | Converts a t'Full.ExecutableDefinition' into a string.
|
||||||
definition :: Formatter -> Full.Definition -> Lazy.Text
|
definition :: Formatter -> ExecutableDefinition -> Lazy.Text
|
||||||
definition formatter x
|
definition formatter x
|
||||||
| Pretty _ <- formatter = Lazy.Text.snoc (encodeDefinition x) '\n'
|
| Pretty _ <- formatter = Lazy.Text.snoc (encodeDefinition x) '\n'
|
||||||
| Minified <- formatter = encodeDefinition x
|
| Minified <- formatter = encodeDefinition x
|
||||||
|
@ -62,14 +64,16 @@ definition formatter x
|
||||||
encodeDefinition (Full.DefinitionFragment fragment)
|
encodeDefinition (Full.DefinitionFragment fragment)
|
||||||
= fragmentDefinition formatter fragment
|
= fragmentDefinition formatter fragment
|
||||||
|
|
||||||
|
-- | Converts a 'Full.OperationDefinition into a string.
|
||||||
operationDefinition :: Formatter -> Full.OperationDefinition -> Lazy.Text
|
operationDefinition :: Formatter -> Full.OperationDefinition -> Lazy.Text
|
||||||
operationDefinition formatter (Full.OperationSelectionSet sels)
|
operationDefinition formatter (Full.SelectionSet sels)
|
||||||
= selectionSet formatter sels
|
= selectionSet formatter sels
|
||||||
operationDefinition formatter (Full.OperationDefinition Full.Query name vars dirs sels)
|
operationDefinition formatter (Full.OperationDefinition Full.Query name vars dirs sels)
|
||||||
= "query " <> node formatter name vars dirs sels
|
= "query " <> node formatter name vars dirs sels
|
||||||
operationDefinition formatter (Full.OperationDefinition Full.Mutation name vars dirs sels)
|
operationDefinition formatter (Full.OperationDefinition Full.Mutation name vars dirs sels)
|
||||||
= "mutation " <> node formatter name vars dirs sels
|
= "mutation " <> node formatter name vars dirs sels
|
||||||
|
|
||||||
|
-- | Converts a Full.Query or Full.Mutation into a string.
|
||||||
node :: Formatter ->
|
node :: Formatter ->
|
||||||
Maybe Full.Name ->
|
Maybe Full.Name ->
|
||||||
[Full.VariableDefinition] ->
|
[Full.VariableDefinition] ->
|
||||||
|
@ -110,17 +114,21 @@ selectionSet formatter
|
||||||
selectionSetOpt :: Formatter -> Full.SelectionSetOpt -> Lazy.Text
|
selectionSetOpt :: Formatter -> Full.SelectionSetOpt -> Lazy.Text
|
||||||
selectionSetOpt formatter = bracesList formatter $ selection formatter
|
selectionSetOpt formatter = bracesList formatter $ selection formatter
|
||||||
|
|
||||||
|
indentSymbol :: Lazy.Text
|
||||||
|
indentSymbol = " "
|
||||||
|
|
||||||
indent :: (Integral a) => a -> Lazy.Text
|
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 -> Full.Selection -> Lazy.Text
|
||||||
selection formatter = Lazy.Text.append indent' . encodeSelection
|
selection formatter = Lazy.Text.append indent' . encodeSelection
|
||||||
where
|
where
|
||||||
encodeSelection (Full.SelectionField field') = field incrementIndent field'
|
encodeSelection (Full.Field alias name args directives' selections) =
|
||||||
encodeSelection (Full.SelectionInlineFragment fragment) =
|
field incrementIndent alias name args directives' selections
|
||||||
inlineFragment incrementIndent fragment
|
encodeSelection (Full.InlineFragment typeCondition directives' selections) =
|
||||||
encodeSelection (Full.SelectionFragmentSpread spread) =
|
inlineFragment incrementIndent typeCondition directives' selections
|
||||||
fragmentSpread incrementIndent spread
|
encodeSelection (Full.FragmentSpread name directives') =
|
||||||
|
fragmentSpread incrementIndent name directives'
|
||||||
incrementIndent
|
incrementIndent
|
||||||
| Pretty indentation <- formatter = Pretty $ indentation + 1
|
| Pretty indentation <- formatter = Pretty $ indentation + 1
|
||||||
| otherwise = Minified
|
| otherwise = Minified
|
||||||
|
@ -131,8 +139,15 @@ selection formatter = Lazy.Text.append indent' . encodeSelection
|
||||||
colon :: Formatter -> Lazy.Text
|
colon :: Formatter -> Lazy.Text
|
||||||
colon formatter = eitherFormat formatter ": " ":"
|
colon formatter = eitherFormat formatter ": " ":"
|
||||||
|
|
||||||
field :: Formatter -> Full.Field -> Lazy.Text
|
-- | Converts Full.Field into a string
|
||||||
field formatter (Full.Field alias name args dirs set)
|
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)
|
= optempty prependAlias (fold alias)
|
||||||
<> Lazy.Text.fromStrict name
|
<> Lazy.Text.fromStrict name
|
||||||
<> optempty (arguments formatter) args
|
<> optempty (arguments formatter) args
|
||||||
|
@ -154,13 +169,18 @@ argument formatter (Full.Argument name value')
|
||||||
|
|
||||||
-- * Fragments
|
-- * Fragments
|
||||||
|
|
||||||
fragmentSpread :: Formatter -> Full.FragmentSpread -> Lazy.Text
|
fragmentSpread :: Formatter -> Full.Name -> [Full.Directive] -> Lazy.Text
|
||||||
fragmentSpread formatter (Full.FragmentSpread name ds)
|
fragmentSpread formatter name directives'
|
||||||
= "..." <> Lazy.Text.fromStrict name <> optempty (directives formatter) ds
|
= "..." <> Lazy.Text.fromStrict name
|
||||||
|
<> optempty (directives formatter) directives'
|
||||||
|
|
||||||
inlineFragment :: Formatter -> Full.InlineFragment -> Lazy.Text
|
inlineFragment ::
|
||||||
inlineFragment formatter (Full.InlineFragment tc dirs sels)
|
Formatter ->
|
||||||
= "... on "
|
Maybe Full.TypeCondition ->
|
||||||
|
[Full.Directive] ->
|
||||||
|
Full.SelectionSet ->
|
||||||
|
Lazy.Text
|
||||||
|
inlineFragment formatter tc dirs sels = "... on "
|
||||||
<> Lazy.Text.fromStrict (fold tc)
|
<> Lazy.Text.fromStrict (fold tc)
|
||||||
<> directives formatter dirs
|
<> directives formatter dirs
|
||||||
<> eitherFormat formatter " " mempty
|
<> eitherFormat formatter " " mempty
|
||||||
|
@ -191,7 +211,7 @@ value _ (Full.Variable x) = variable x
|
||||||
value _ (Full.Int x) = Builder.toLazyText $ decimal x
|
value _ (Full.Int x) = Builder.toLazyText $ decimal x
|
||||||
value _ (Full.Float x) = Builder.toLazyText $ realFloat x
|
value _ (Full.Float x) = Builder.toLazyText $ realFloat x
|
||||||
value _ (Full.Boolean x) = booleanValue x
|
value _ (Full.Boolean x) = booleanValue x
|
||||||
value _ Full.Null = mempty
|
value _ Full.Null = "null"
|
||||||
value formatter (Full.String string) = stringValue formatter string
|
value formatter (Full.String string) = stringValue formatter string
|
||||||
value _ (Full.Enum x) = Lazy.Text.fromStrict x
|
value _ (Full.Enum x) = Lazy.Text.fromStrict x
|
||||||
value formatter (Full.List x) = listValue formatter x
|
value formatter (Full.List x) = listValue formatter x
|
||||||
|
@ -201,26 +221,40 @@ booleanValue :: Bool -> Lazy.Text
|
||||||
booleanValue True = "true"
|
booleanValue True = "true"
|
||||||
booleanValue False = "false"
|
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 :: Formatter -> Text -> Lazy.Text
|
||||||
stringValue Minified string = Builder.toLazyText
|
stringValue Minified string = Builder.toLazyText
|
||||||
$ quote <> Text.foldr (mappend . escape') quote string
|
$ quote <> Text.foldr (mappend . escape) quote string
|
||||||
where
|
stringValue (Pretty indentation) string =
|
||||||
quote = Builder.singleton '\"'
|
if hasEscaped string
|
||||||
escape' '\n' = Builder.fromString "\\n"
|
then stringValue Minified string
|
||||||
escape' char = escape char
|
else Builder.toLazyText $ encoded lines'
|
||||||
stringValue (Pretty indentation) string = byStringType $ Text.lines string
|
where
|
||||||
where
|
isWhiteSpace char = char == ' ' || char == '\t'
|
||||||
byStringType [] = "\"\""
|
isNewline char = char == '\n' || char == '\r'
|
||||||
byStringType [line] = Builder.toLazyText
|
hasEscaped = Text.any (not . isAllowed)
|
||||||
$ quote <> Text.foldr (mappend . escape) quote line
|
isAllowed char =
|
||||||
byStringType lines' = "\"\"\"\n"
|
char == '\t' || isNewline char || (char >= '\x0020' && char /= '\x007F')
|
||||||
<> Lazy.Text.unlines (transformLine <$> lines')
|
|
||||||
<> indent indentation
|
tripleQuote = Builder.fromText "\"\"\""
|
||||||
<> "\"\"\""
|
start = tripleQuote <> Builder.singleton '\n'
|
||||||
transformLine = (indent (indentation + 1) <>)
|
end = Builder.fromLazyText (indent indentation) <> tripleQuote
|
||||||
. Lazy.Text.fromStrict
|
|
||||||
. Text.replace "\"\"\"" "\\\"\"\""
|
strip = Text.dropWhile isWhiteSpace . Text.dropWhileEnd isWhiteSpace
|
||||||
quote = Builder.singleton '\"'
|
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 -> Builder
|
||||||
escape char'
|
escape char'
|
||||||
|
@ -228,7 +262,9 @@ escape char'
|
||||||
| char' == '\"' = Builder.fromString "\\\""
|
| char' == '\"' = Builder.fromString "\\\""
|
||||||
| char' == '\b' = Builder.fromString "\\b"
|
| char' == '\b' = Builder.fromString "\\b"
|
||||||
| char' == '\f' = Builder.fromString "\\f"
|
| char' == '\f' = Builder.fromString "\\f"
|
||||||
|
| char' == '\n' = Builder.fromString "\\n"
|
||||||
| char' == '\r' = Builder.fromString "\\r"
|
| char' == '\r' = Builder.fromString "\\r"
|
||||||
|
| char' == '\t' = Builder.fromString "\\t"
|
||||||
| char' < '\x0010' = unicode "\\u000" char'
|
| char' < '\x0010' = unicode "\\u000" char'
|
||||||
| char' < '\x0020' = unicode "\\u00" char'
|
| char' < '\x0020' = unicode "\\u00" char'
|
||||||
| otherwise = Builder.singleton char'
|
| otherwise = Builder.singleton char'
|
||||||
|
|
|
@ -15,6 +15,7 @@ module Language.GraphQL.AST.Lexer
|
||||||
, dollar
|
, dollar
|
||||||
, comment
|
, comment
|
||||||
, equals
|
, equals
|
||||||
|
, extend
|
||||||
, integer
|
, integer
|
||||||
, float
|
, float
|
||||||
, lexeme
|
, lexeme
|
||||||
|
@ -28,20 +29,16 @@ module Language.GraphQL.AST.Lexer
|
||||||
, unicodeBOM
|
, unicodeBOM
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Control.Applicative ( Alternative(..)
|
import Control.Applicative (Alternative(..), liftA2)
|
||||||
, liftA2
|
import Data.Char (chr, digitToInt, isAsciiLower, isAsciiUpper, ord)
|
||||||
)
|
|
||||||
import Data.Char ( chr
|
|
||||||
, digitToInt
|
|
||||||
, isAsciiLower
|
|
||||||
, isAsciiUpper
|
|
||||||
, ord
|
|
||||||
)
|
|
||||||
import Data.Foldable (foldl')
|
import Data.Foldable (foldl')
|
||||||
import Data.List (dropWhileEnd)
|
import Data.List (dropWhileEnd)
|
||||||
|
import qualified Data.List.NonEmpty as NonEmpty
|
||||||
|
import Data.List.NonEmpty (NonEmpty(..))
|
||||||
import Data.Proxy (Proxy(..))
|
import Data.Proxy (Proxy(..))
|
||||||
import Data.Void (Void)
|
import Data.Void (Void)
|
||||||
import Text.Megaparsec ( Parsec
|
import Text.Megaparsec ( Parsec
|
||||||
|
, (<?>)
|
||||||
, between
|
, between
|
||||||
, chunk
|
, chunk
|
||||||
, chunkToTokens
|
, chunkToTokens
|
||||||
|
@ -56,11 +53,9 @@ import Text.Megaparsec ( Parsec
|
||||||
, takeWhile1P
|
, takeWhile1P
|
||||||
, try
|
, try
|
||||||
)
|
)
|
||||||
import Text.Megaparsec.Char ( char
|
import Text.Megaparsec.Char (char, digitChar, space1)
|
||||||
, digitChar
|
|
||||||
, space1
|
|
||||||
)
|
|
||||||
import qualified Text.Megaparsec.Char.Lexer as Lexer
|
import qualified Text.Megaparsec.Char.Lexer as Lexer
|
||||||
|
import Data.Text (Text)
|
||||||
import qualified Data.Text as T
|
import qualified Data.Text as T
|
||||||
import qualified Data.Text.Lazy as TL
|
import qualified Data.Text.Lazy as TL
|
||||||
|
|
||||||
|
@ -97,8 +92,8 @@ dollar :: Parser T.Text
|
||||||
dollar = symbol "$"
|
dollar = symbol "$"
|
||||||
|
|
||||||
-- | Parser for "@".
|
-- | Parser for "@".
|
||||||
at :: Parser Char
|
at :: Parser Text
|
||||||
at = char '@'
|
at = symbol "@"
|
||||||
|
|
||||||
-- | Parser for "&".
|
-- | Parser for "&".
|
||||||
amp :: Parser T.Text
|
amp :: Parser T.Text
|
||||||
|
@ -134,7 +129,7 @@ braces = between (symbol "{") (symbol "}")
|
||||||
|
|
||||||
-- | Parser for strings.
|
-- | Parser for strings.
|
||||||
string :: Parser T.Text
|
string :: Parser T.Text
|
||||||
string = between "\"" "\"" stringValue <* spaceConsumer
|
string = between "\"" "\"" stringValue <* spaceConsumer
|
||||||
where
|
where
|
||||||
stringValue = T.pack <$> many stringCharacter
|
stringValue = T.pack <$> many stringCharacter
|
||||||
stringCharacter = satisfy isStringCharacter1
|
stringCharacter = satisfy isStringCharacter1
|
||||||
|
@ -143,7 +138,7 @@ string = between "\"" "\"" stringValue <* spaceConsumer
|
||||||
|
|
||||||
-- | Parser for block strings.
|
-- | Parser for block strings.
|
||||||
blockString :: Parser T.Text
|
blockString :: Parser T.Text
|
||||||
blockString = between "\"\"\"" "\"\"\"" stringValue <* spaceConsumer
|
blockString = between "\"\"\"" "\"\"\"" stringValue <* spaceConsumer
|
||||||
where
|
where
|
||||||
stringValue = do
|
stringValue = do
|
||||||
byLine <- sepBy (many blockStringCharacter) lineTerminator
|
byLine <- sepBy (many blockStringCharacter) lineTerminator
|
||||||
|
@ -226,3 +221,16 @@ escapeSequence = do
|
||||||
-- | Parser for the "Byte Order Mark".
|
-- | Parser for the "Byte Order Mark".
|
||||||
unicodeBOM :: Parser ()
|
unicodeBOM :: Parser ()
|
||||||
unicodeBOM = optional (char '\xfeff') >> pure ()
|
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
|
( document
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Control.Applicative ( Alternative(..)
|
import Control.Applicative (Alternative(..), optional)
|
||||||
, optional
|
import Control.Applicative.Combinators (sepBy1)
|
||||||
)
|
import qualified Control.Applicative.Combinators.NonEmpty as NonEmpty
|
||||||
import Data.List.NonEmpty (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 Language.GraphQL.AST.Lexer
|
||||||
import Text.Megaparsec ( lookAhead
|
import Text.Megaparsec (lookAhead, option, try, (<?>))
|
||||||
, option
|
|
||||||
, try
|
|
||||||
, (<?>)
|
|
||||||
)
|
|
||||||
|
|
||||||
-- | Parser for the GraphQL documents.
|
-- | Parser for the GraphQL documents.
|
||||||
document :: Parser Document
|
document :: Parser Document
|
||||||
document = unicodeBOM >> spaceConsumer >> lexeme (manyNE definition)
|
document = unicodeBOM
|
||||||
|
>> spaceConsumer
|
||||||
|
>> lexeme (NonEmpty.some definition)
|
||||||
|
|
||||||
definition :: Parser Definition
|
definition :: Parser Definition
|
||||||
definition = DefinitionOperation <$> operationDefinition
|
definition = ExecutableDefinition <$> executableDefinition
|
||||||
<|> DefinitionFragment <$> fragmentDefinition
|
<|> TypeSystemDefinition <$> typeSystemDefinition
|
||||||
<?> "definition error!"
|
<|> 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 :: Parser OperationDefinition
|
||||||
operationDefinition = OperationSelectionSet <$> selectionSet
|
operationDefinition = SelectionSet <$> selectionSet
|
||||||
<|> OperationDefinition <$> operationType
|
<|> operationDefinition'
|
||||||
<*> optional name
|
<?> "operationDefinition error"
|
||||||
<*> opt variableDefinitions
|
where
|
||||||
<*> opt directives
|
operationDefinition'
|
||||||
<*> selectionSet
|
= OperationDefinition <$> operationType
|
||||||
<?> "operationDefinition error"
|
<*> optional name
|
||||||
|
<*> variableDefinitions
|
||||||
|
<*> directives
|
||||||
|
<*> selectionSet
|
||||||
|
|
||||||
operationType :: Parser OperationType
|
operationType :: Parser OperationType
|
||||||
operationType = Query <$ symbol "query"
|
operationType = Query <$ symbol "query"
|
||||||
<|> Mutation <$ symbol "mutation"
|
<|> Mutation <$ symbol "mutation"
|
||||||
<?> "operationType error"
|
-- <?> Keep default error message
|
||||||
|
|
||||||
-- * SelectionSet
|
-- * SelectionSet
|
||||||
|
|
||||||
selectionSet :: Parser SelectionSet
|
selectionSet :: Parser SelectionSet
|
||||||
selectionSet = braces $ manyNE selection
|
selectionSet = braces $ NonEmpty.some selection
|
||||||
|
|
||||||
selectionSetOpt :: Parser SelectionSetOpt
|
selectionSetOpt :: Parser SelectionSetOpt
|
||||||
selectionSetOpt = braces $ some selection
|
selectionSetOpt = listOptIn braces selection
|
||||||
|
|
||||||
selection :: Parser Selection
|
selection :: Parser Selection
|
||||||
selection = SelectionField <$> field
|
selection = field
|
||||||
<|> try (SelectionFragmentSpread <$> fragmentSpread)
|
<|> try fragmentSpread
|
||||||
<|> SelectionInlineFragment <$> inlineFragment
|
<|> inlineFragment
|
||||||
<?> "selection error!"
|
<?> "selection error!"
|
||||||
|
|
||||||
-- * Field
|
-- * Field
|
||||||
|
|
||||||
field :: Parser Field
|
field :: Parser Selection
|
||||||
field = Field <$> optional alias
|
field = Field
|
||||||
<*> name
|
<$> optional alias
|
||||||
<*> opt arguments
|
<*> name
|
||||||
<*> opt directives
|
<*> arguments
|
||||||
<*> opt selectionSetOpt
|
<*> directives
|
||||||
|
<*> selectionSetOpt
|
||||||
|
|
||||||
alias :: Parser Alias
|
alias :: Parser Alias
|
||||||
alias = try $ name <* colon
|
alias = try $ name <* colon
|
||||||
|
@ -70,30 +365,32 @@ alias = try $ name <* colon
|
||||||
-- * Arguments
|
-- * Arguments
|
||||||
|
|
||||||
arguments :: Parser [Argument]
|
arguments :: Parser [Argument]
|
||||||
arguments = parens $ some argument
|
arguments = listOptIn parens argument
|
||||||
|
|
||||||
argument :: Parser Argument
|
argument :: Parser Argument
|
||||||
argument = Argument <$> name <* colon <*> value
|
argument = Argument <$> name <* colon <*> value
|
||||||
|
|
||||||
-- * Fragments
|
-- * Fragments
|
||||||
|
|
||||||
fragmentSpread :: Parser FragmentSpread
|
fragmentSpread :: Parser Selection
|
||||||
fragmentSpread = FragmentSpread <$ spread
|
fragmentSpread = FragmentSpread
|
||||||
<*> fragmentName
|
<$ spread
|
||||||
<*> opt directives
|
<*> fragmentName
|
||||||
|
<*> directives
|
||||||
|
|
||||||
inlineFragment :: Parser InlineFragment
|
inlineFragment :: Parser Selection
|
||||||
inlineFragment = InlineFragment <$ spread
|
inlineFragment = InlineFragment
|
||||||
<*> optional typeCondition
|
<$ spread
|
||||||
<*> opt directives
|
<*> optional typeCondition
|
||||||
<*> selectionSet
|
<*> directives
|
||||||
|
<*> selectionSet
|
||||||
|
|
||||||
fragmentDefinition :: Parser FragmentDefinition
|
fragmentDefinition :: Parser FragmentDefinition
|
||||||
fragmentDefinition = FragmentDefinition
|
fragmentDefinition = FragmentDefinition
|
||||||
<$ symbol "fragment"
|
<$ symbol "fragment"
|
||||||
<*> name
|
<*> name
|
||||||
<*> typeCondition
|
<*> typeCondition
|
||||||
<*> opt directives
|
<*> directives
|
||||||
<*> selectionSet
|
<*> selectionSet
|
||||||
|
|
||||||
fragmentName :: Parser Name
|
fragmentName :: Parser Name
|
||||||
|
@ -121,68 +418,68 @@ value = Variable <$> variable
|
||||||
booleanValue = True <$ symbol "true"
|
booleanValue = True <$ symbol "true"
|
||||||
<|> False <$ symbol "false"
|
<|> False <$ symbol "false"
|
||||||
|
|
||||||
enumValue :: Parser Name
|
|
||||||
enumValue = but (symbol "true") *> but (symbol "false") *> but (symbol "null") *> name
|
|
||||||
|
|
||||||
listValue :: Parser [Value]
|
listValue :: Parser [Value]
|
||||||
listValue = brackets $ some value
|
listValue = brackets $ some value
|
||||||
|
|
||||||
objectValue :: Parser [ObjectField]
|
objectValue :: Parser [ObjectField]
|
||||||
objectValue = braces $ some objectField
|
objectValue = braces $ some objectField
|
||||||
|
|
||||||
|
enumValue :: Parser Name
|
||||||
|
enumValue = but (symbol "true") *> but (symbol "false") *> but (symbol "null") *> name
|
||||||
|
|
||||||
objectField :: Parser ObjectField
|
objectField :: Parser ObjectField
|
||||||
objectField = ObjectField <$> name <* symbol ":" <*> value
|
objectField = ObjectField <$> name <* colon <*> value
|
||||||
|
|
||||||
-- * Variables
|
-- * Variables
|
||||||
|
|
||||||
variableDefinitions :: Parser [VariableDefinition]
|
variableDefinitions :: Parser [VariableDefinition]
|
||||||
variableDefinitions = parens $ some variableDefinition
|
variableDefinitions = listOptIn parens variableDefinition
|
||||||
|
|
||||||
variableDefinition :: Parser VariableDefinition
|
variableDefinition :: Parser VariableDefinition
|
||||||
variableDefinition = VariableDefinition <$> variable
|
variableDefinition = VariableDefinition
|
||||||
<* colon
|
<$> variable
|
||||||
<*> type_
|
<* colon
|
||||||
<*> optional defaultValue
|
<*> type'
|
||||||
|
<*> defaultValue
|
||||||
|
<?> "VariableDefinition"
|
||||||
|
|
||||||
variable :: Parser Name
|
variable :: Parser Name
|
||||||
variable = dollar *> name
|
variable = dollar *> name
|
||||||
|
|
||||||
defaultValue :: Parser Value
|
defaultValue :: Parser (Maybe Value)
|
||||||
defaultValue = equals *> value
|
defaultValue = optional (equals *> value) <?> "DefaultValue"
|
||||||
|
|
||||||
-- * Input Types
|
-- * Input Types
|
||||||
|
|
||||||
type_ :: Parser Type
|
type' :: Parser Type
|
||||||
type_ = try (TypeNonNull <$> nonNullType)
|
type' = try (TypeNonNull <$> nonNullType)
|
||||||
<|> TypeList <$> brackets type_
|
<|> TypeList <$> brackets type'
|
||||||
<|> TypeNamed <$> name
|
<|> TypeNamed <$> name
|
||||||
<?> "type_ error!"
|
<?> "Type"
|
||||||
|
|
||||||
nonNullType :: Parser NonNullType
|
nonNullType :: Parser NonNullType
|
||||||
nonNullType = NonNullTypeNamed <$> name <* bang
|
nonNullType = NonNullTypeNamed <$> name <* bang
|
||||||
<|> NonNullTypeList <$> brackets type_ <* bang
|
<|> NonNullTypeList <$> brackets type' <* bang
|
||||||
<?> "nonNullType error!"
|
<?> "nonNullType error!"
|
||||||
|
|
||||||
-- * Directives
|
-- * Directives
|
||||||
|
|
||||||
directives :: Parser [Directive]
|
directives :: Parser [Directive]
|
||||||
directives = some directive
|
directives = many directive
|
||||||
|
|
||||||
directive :: Parser Directive
|
directive :: Parser Directive
|
||||||
directive = Directive
|
directive = Directive
|
||||||
<$ at
|
<$ at
|
||||||
<*> name
|
<*> name
|
||||||
<*> opt arguments
|
<*> arguments
|
||||||
|
|
||||||
-- * Internal
|
-- * Internal
|
||||||
|
|
||||||
opt :: Monoid a => Parser a -> Parser a
|
listOptIn :: (Parser [a] -> Parser [a]) -> Parser a -> Parser [a]
|
||||||
opt = option mempty
|
listOptIn surround = option [] . surround . some
|
||||||
|
|
||||||
-- Hack to reverse parser success
|
-- Hack to reverse parser success
|
||||||
but :: Parser a -> Parser ()
|
but :: Parser a -> Parser ()
|
||||||
but pn = False <$ lookAhead pn <|> pure True >>= \case
|
but pn = False <$ lookAhead pn <|> pure True >>= \case
|
||||||
False -> empty
|
False -> empty
|
||||||
True -> pure ()
|
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
|
, modify
|
||||||
, runStateT
|
, runStateT
|
||||||
)
|
)
|
||||||
import Text.Megaparsec ( ParseErrorBundle(..)
|
import Text.Megaparsec
|
||||||
, SourcePos(..)
|
( ParseErrorBundle(..)
|
||||||
, errorOffset
|
, PosState(..)
|
||||||
, parseErrorTextPretty
|
, SourcePos(..)
|
||||||
, reachOffset
|
, errorOffset
|
||||||
, unPos
|
, parseErrorTextPretty
|
||||||
)
|
, reachOffset
|
||||||
|
, unPos
|
||||||
|
)
|
||||||
|
|
||||||
-- | Wraps a parse error into a list of errors.
|
-- | Wraps a parse error into a list of errors.
|
||||||
parseError :: Applicative f => ParseErrorBundle Text Void -> f Aeson.Value
|
parseError :: Applicative f => ParseErrorBundle Text Void -> f Aeson.Value
|
||||||
parseError ParseErrorBundle{..} =
|
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
|
where
|
||||||
errorObject s SourcePos{..} = Aeson.object
|
errorObject s SourcePos{..} = Aeson.object
|
||||||
[ ("message", Aeson.toJSON $ init $ parseErrorTextPretty s)
|
[ ("message", Aeson.toJSON $ init $ parseErrorTextPretty s)
|
||||||
|
@ -39,7 +41,8 @@ parseError ParseErrorBundle{..} =
|
||||||
, ("column", Aeson.toJSON $ unPos sourceColumn)
|
, ("column", Aeson.toJSON $ unPos sourceColumn)
|
||||||
]
|
]
|
||||||
go (result, state) x =
|
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)
|
in (errorObject x sourcePosition : result, newState)
|
||||||
|
|
||||||
-- | A wrapper to pass error messages around.
|
-- | A wrapper to pass error messages around.
|
||||||
|
|
|
@ -6,14 +6,14 @@ module Language.GraphQL.Execute
|
||||||
, executeWithName
|
, executeWithName
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Control.Monad.IO.Class (MonadIO)
|
|
||||||
import qualified Data.Aeson as Aeson
|
import qualified Data.Aeson as Aeson
|
||||||
import Data.Foldable (toList)
|
|
||||||
import Data.List.NonEmpty (NonEmpty(..))
|
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 Data.Text (Text)
|
||||||
import qualified Data.Text as 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.AST.Core as AST.Core
|
||||||
import qualified Language.GraphQL.Execute.Transform as Transform
|
import qualified Language.GraphQL.Execute.Transform as Transform
|
||||||
import Language.GraphQL.Error
|
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/
|
-- Returns the result of the query against the schema wrapped in a /data/
|
||||||
-- field, or errors wrapped in an /errors/ field.
|
-- field, or errors wrapped in an /errors/ field.
|
||||||
execute :: MonadIO m
|
execute :: Monad m
|
||||||
=> NonEmpty (Schema.Resolver m) -- ^ Resolvers.
|
=> HashMap Text (NonEmpty (Schema.Resolver m)) -- ^ Resolvers.
|
||||||
-> Schema.Subs -- ^ Variable substitution function.
|
-> Schema.Subs -- ^ Variable substitution function.
|
||||||
-> AST.Document -- @GraphQL@ document.
|
-> Document -- @GraphQL@ document.
|
||||||
-> m Aeson.Value
|
-> m Aeson.Value
|
||||||
execute schema subs doc =
|
execute schema subs doc =
|
||||||
maybe transformError (document schema Nothing) $ Transform.document subs doc
|
maybe transformError (document schema Nothing)
|
||||||
|
$ Transform.document subs doc
|
||||||
where
|
where
|
||||||
transformError = return $ singleError "Schema transformation error."
|
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/
|
-- Returns the result of the query against the schema wrapped in a /data/
|
||||||
-- field, or errors wrapped in an /errors/ field.
|
-- field, or errors wrapped in an /errors/ field.
|
||||||
executeWithName :: MonadIO m
|
executeWithName :: Monad m
|
||||||
=> NonEmpty (Schema.Resolver m) -- ^ Resolvers
|
=> HashMap Text (NonEmpty (Schema.Resolver m)) -- ^ Resolvers
|
||||||
-> Text -- ^ Operation name.
|
-> Text -- ^ Operation name.
|
||||||
-> Schema.Subs -- ^ Variable substitution function.
|
-> Schema.Subs -- ^ Variable substitution function.
|
||||||
-> AST.Document -- ^ @GraphQL@ Document.
|
-> Document -- ^ @GraphQL@ Document.
|
||||||
-> m Aeson.Value
|
-> m Aeson.Value
|
||||||
executeWithName schema name subs doc =
|
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
|
where
|
||||||
transformError = return $ singleError "Schema transformation error."
|
transformError = return $ singleError "Schema transformation error."
|
||||||
|
|
||||||
document :: MonadIO m
|
document :: Monad m
|
||||||
=> NonEmpty (Schema.Resolver m)
|
=> HashMap Text (NonEmpty (Schema.Resolver m))
|
||||||
-> Maybe Text
|
-> Maybe Text
|
||||||
-> AST.Core.Document
|
-> AST.Core.Document
|
||||||
-> m Aeson.Value
|
-> m Aeson.Value
|
||||||
document schema Nothing (op :| []) = operation schema op
|
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
|
[] -> return $ singleError
|
||||||
$ Text.unwords ["Operation", name, "couldn't be found in the document."]
|
$ Text.unwords ["Operation", name, "couldn't be found in the document."]
|
||||||
(op:_) -> operation schema op
|
(op:_) -> operation schema op
|
||||||
|
@ -67,11 +69,18 @@ document schema (Just name) operations = case NE.dropWhile matchingName operatio
|
||||||
matchingName _ = False
|
matchingName _ = False
|
||||||
document _ _ _ = return $ singleError "Missing operation name."
|
document _ _ _ = return $ singleError "Missing operation name."
|
||||||
|
|
||||||
operation :: MonadIO m
|
operation :: Monad m
|
||||||
=> NonEmpty (Schema.Resolver m)
|
=> HashMap Text (NonEmpty (Schema.Resolver m))
|
||||||
-> AST.Core.Operation
|
-> AST.Core.Operation
|
||||||
-> m Aeson.Value
|
-> m Aeson.Value
|
||||||
operation schema (AST.Core.Query _ flds)
|
operation schema = schemaOperation
|
||||||
= runCollectErrs (Schema.resolve (toList schema) flds)
|
where
|
||||||
operation schema (AST.Core.Mutation _ flds)
|
runResolver fields = runCollectErrs
|
||||||
= runCollectErrs (Schema.resolve (toList schema) flds)
|
. 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.Arrow (first)
|
||||||
import Control.Monad (foldM, unless)
|
import Control.Monad (foldM, unless)
|
||||||
import Control.Monad.Trans.Class (lift)
|
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 Control.Monad.Trans.State (StateT, evalStateT, gets, modify)
|
||||||
import Data.HashMap.Strict (HashMap)
|
import Data.HashMap.Strict (HashMap)
|
||||||
import qualified Data.HashMap.Strict as HashMap
|
import qualified Data.HashMap.Strict as HashMap
|
||||||
|
@ -19,6 +19,7 @@ import qualified Data.List.NonEmpty as NonEmpty
|
||||||
import Data.Sequence (Seq, (<|), (><))
|
import Data.Sequence (Seq, (<|), (><))
|
||||||
import qualified Language.GraphQL.AST as Full
|
import qualified Language.GraphQL.AST as Full
|
||||||
import qualified Language.GraphQL.AST.Core as Core
|
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.Schema as Schema
|
||||||
import qualified Language.GraphQL.Type.Directive as Directive
|
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
|
-- | Rewrites the original syntax tree into an intermediate representation used
|
||||||
-- for query execution.
|
-- for query execution.
|
||||||
document :: Schema.Subs -> Full.Document -> Maybe Core.Document
|
document :: Schema.Subs -> Document -> Maybe Core.Document
|
||||||
document subs document' =
|
document subs document' =
|
||||||
flip runReaderT subs
|
flip runReaderT subs
|
||||||
$ evalStateT (collectFragments >> operations operationDefinitions)
|
$ evalStateT (collectFragments >> operations operationDefinitions)
|
||||||
$ Replacement HashMap.empty fragmentTable
|
$ Replacement HashMap.empty fragmentTable
|
||||||
where
|
where
|
||||||
(fragmentTable, operationDefinitions) = foldr defragment mempty document'
|
(fragmentTable, operationDefinitions) = foldr defragment mempty document'
|
||||||
defragment (Full.DefinitionOperation definition) acc =
|
defragment (ExecutableDefinition (Full.DefinitionOperation definition)) acc =
|
||||||
(definition :) <$> acc
|
(definition :) <$> acc
|
||||||
defragment (Full.DefinitionFragment definition) acc =
|
defragment (ExecutableDefinition (Full.DefinitionFragment definition)) acc =
|
||||||
let (Full.FragmentDefinition name _ _ _) = definition
|
let (Full.FragmentDefinition name _ _ _) = definition
|
||||||
in first (HashMap.insert name definition) acc
|
in first (HashMap.insert name definition) acc
|
||||||
|
defragment _ acc = acc
|
||||||
|
|
||||||
-- * Operation
|
-- * Operation
|
||||||
|
|
||||||
|
@ -56,26 +58,47 @@ operations operations' = do
|
||||||
lift . lift $ NonEmpty.nonEmpty coreOperations
|
lift . lift $ NonEmpty.nonEmpty coreOperations
|
||||||
|
|
||||||
operation :: Full.OperationDefinition -> TransformT Core.Operation
|
operation :: Full.OperationDefinition -> TransformT Core.Operation
|
||||||
operation (Full.OperationSelectionSet sels) =
|
operation (Full.SelectionSet sels)
|
||||||
operation $ Full.OperationDefinition Full.Query mempty mempty mempty 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)
|
||||||
operation (Full.OperationDefinition Full.Query name _vars _dirs sels) =
|
= Core.Query name <$> appendSelection sels
|
||||||
Core.Query name <$> appendSelection sels
|
operation (Full.OperationDefinition Full.Mutation name _vars _dirs sels)
|
||||||
operation (Full.OperationDefinition Full.Mutation name _vars _dirs sels) =
|
= Core.Mutation name <$> appendSelection sels
|
||||||
Core.Mutation name <$> appendSelection sels
|
|
||||||
|
|
||||||
-- * Selection
|
-- * Selection
|
||||||
|
|
||||||
selection ::
|
selection ::
|
||||||
Full.Selection ->
|
Full.Selection ->
|
||||||
TransformT (Either (Seq Core.Selection) Core.Selection)
|
TransformT (Either (Seq Core.Selection) Core.Selection)
|
||||||
selection (Full.SelectionField field') =
|
selection (Full.Field alias name arguments' directives' selections) =
|
||||||
maybe (Left mempty) (Right . Core.SelectionField) <$> field field'
|
maybe (Left mempty) (Right . Core.SelectionField) <$> do
|
||||||
selection (Full.SelectionFragmentSpread fragment) =
|
fieldArguments <- arguments arguments'
|
||||||
maybe (Left mempty) (Right . Core.SelectionFragment)
|
fieldSelections <- appendSelection selections
|
||||||
<$> fragmentSpread fragment
|
fieldDirectives <- Directive.selection <$> directives directives'
|
||||||
selection (Full.SelectionInlineFragment fragment) =
|
let field' = Core.Field alias name fieldArguments fieldSelections
|
||||||
inlineFragment fragment
|
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 ::
|
appendSelection ::
|
||||||
Traversable t =>
|
Traversable t =>
|
||||||
|
@ -104,33 +127,6 @@ collectFragments = do
|
||||||
_ <- fragmentDefinition nextValue
|
_ <- fragmentDefinition nextValue
|
||||||
collectFragments
|
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 ::
|
fragmentDefinition ::
|
||||||
Full.FragmentDefinition ->
|
Full.FragmentDefinition ->
|
||||||
TransformT Core.Fragment
|
TransformT Core.Fragment
|
||||||
|
@ -147,28 +143,15 @@ fragmentDefinition (Full.FragmentDefinition name type' _ selections) = do
|
||||||
let newFragments = HashMap.insert name newValue fragments'
|
let newFragments = HashMap.insert name newValue fragments'
|
||||||
in Replacement newFragments fragmentDefinitions'
|
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 :: [Full.Argument] -> TransformT Core.Arguments
|
||||||
arguments = fmap Core.Arguments . foldM go HashMap.empty
|
arguments = fmap Core.Arguments . foldM go HashMap.empty
|
||||||
where
|
where
|
||||||
go arguments' argument' = do
|
go arguments' (Full.Argument name value') = do
|
||||||
(Core.Argument name value') <- argument argument'
|
substitutedValue <- value value'
|
||||||
return $ HashMap.insert name value' arguments'
|
return $ HashMap.insert name substitutedValue arguments'
|
||||||
|
|
||||||
argument :: Full.Argument -> TransformT Core.Argument
|
|
||||||
argument (Full.Argument n v) = Core.Argument n <$> value v
|
|
||||||
|
|
||||||
value :: Full.Value -> TransformT Core.Value
|
value :: Full.Value -> TransformT Core.Value
|
||||||
value (Full.Variable n) = do
|
value (Full.Variable name) = lift (asks $ HashMap.lookup name) >>= lift . lift
|
||||||
substitute' <- lift ask
|
|
||||||
lift . lift $ substitute' n
|
|
||||||
value (Full.Int i) = pure $ Core.Int i
|
value (Full.Int i) = pure $ Core.Int i
|
||||||
value (Full.Float f) = pure $ Core.Float f
|
value (Full.Float f) = pure $ Core.Float f
|
||||||
value (Full.String x) = pure $ Core.String x
|
value (Full.String x) = pure $ Core.String x
|
||||||
|
|
|
@ -3,28 +3,23 @@
|
||||||
-- | This module provides a representation of a @GraphQL@ Schema in addition to
|
-- | This module provides a representation of a @GraphQL@ Schema in addition to
|
||||||
-- functions for defining and manipulating schemas.
|
-- functions for defining and manipulating schemas.
|
||||||
module Language.GraphQL.Schema
|
module Language.GraphQL.Schema
|
||||||
( Resolver
|
( Resolver(..)
|
||||||
, Subs
|
, Subs
|
||||||
, object
|
, object
|
||||||
, objectA
|
|
||||||
, scalar
|
|
||||||
, scalarA
|
|
||||||
, resolve
|
, resolve
|
||||||
|
, resolversToMap
|
||||||
|
, scalar
|
||||||
, wrappedObject
|
, wrappedObject
|
||||||
, wrappedObjectA
|
|
||||||
, wrappedScalar
|
, wrappedScalar
|
||||||
, wrappedScalarA
|
|
||||||
-- * AST Reexports
|
-- * AST Reexports
|
||||||
, Field
|
, Field
|
||||||
, Argument(..)
|
|
||||||
, Value(..)
|
, Value(..)
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Control.Monad.IO.Class (MonadIO(..))
|
|
||||||
import Control.Monad.Trans.Class (lift)
|
import Control.Monad.Trans.Class (lift)
|
||||||
import Control.Monad.Trans.Except (runExceptT)
|
import Control.Monad.Trans.Except (runExceptT)
|
||||||
import Control.Monad.Trans.Reader (runReaderT)
|
import Control.Monad.Trans.Reader (runReaderT)
|
||||||
import Data.Foldable (find, fold)
|
import Data.Foldable (fold, toList)
|
||||||
import Data.Maybe (fromMaybe)
|
import Data.Maybe (fromMaybe)
|
||||||
import qualified Data.Aeson as Aeson
|
import qualified Data.Aeson as Aeson
|
||||||
import Data.HashMap.Strict (HashMap)
|
import Data.HashMap.Strict (HashMap)
|
||||||
|
@ -38,81 +33,80 @@ import Language.GraphQL.Trans
|
||||||
import qualified Language.GraphQL.Type as Type
|
import qualified Language.GraphQL.Type as Type
|
||||||
|
|
||||||
-- | Resolves a 'Field' into an @Aeson.@'Data.Aeson.Types.Object' with error
|
-- | 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
|
-- information (if an error has occurred). @m@ is an arbitrary monad, usually
|
||||||
-- instance of 'MonadIO'.
|
-- 'IO'.
|
||||||
data Resolver m = Resolver
|
data Resolver m = Resolver
|
||||||
Text -- ^ Name
|
Text -- ^ Name
|
||||||
(Field -> CollectErrsT m Aeson.Object) -- ^ Resolver
|
(Field -> CollectErrsT m Aeson.Object) -- ^ Resolver
|
||||||
|
|
||||||
-- | Variable substitution function.
|
-- | Converts resolvers to a map.
|
||||||
type Subs = Name -> Maybe Value
|
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.
|
-- | Create a new 'Resolver' with the given 'Name' from the given 'Resolver's.
|
||||||
object :: MonadIO m => Name -> ActionT m [Resolver m] -> Resolver m
|
object :: Monad m => Name -> ActionT m [Resolver m] -> Resolver m
|
||||||
object name = objectA name . const
|
object name f = Resolver name $ resolveFieldValue f resolveRight
|
||||||
|
|
||||||
-- | 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
|
|
||||||
where
|
where
|
||||||
resolveRight fld@(Field _ _ _ flds) resolver = withField (resolve resolver flds) fld
|
resolveRight fld@(Field _ _ _ flds) resolver
|
||||||
|
= withField (resolve (resolversToMap 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
|
|
||||||
|
|
||||||
-- | Like 'object' but can be null or a list of objects.
|
-- | Like 'object' but can be null or a list of objects.
|
||||||
wrappedObject :: MonadIO m
|
wrappedObject ::
|
||||||
=> Name -> ActionT m (Type.Wrapping [Resolver m]) -> Resolver m
|
Monad m =>
|
||||||
wrappedObject name = wrappedObjectA name . const
|
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.
|
-- | 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 :: (Monad m, Aeson.ToJSON a) => Name -> ActionT m a -> Resolver m
|
||||||
scalar name = scalarA name . const
|
scalar name f = Resolver name $ resolveFieldValue f resolveRight
|
||||||
|
|
||||||
-- | 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
|
|
||||||
where
|
where
|
||||||
resolveRight fld result = withField (return result) fld
|
resolveRight fld result = withField (return result) fld
|
||||||
|
|
||||||
-- | Like 'scalar' but also taking 'Argument's and can be null or a list of scalars.
|
-- | Like 'scalar' but can be null or a list of scalars.
|
||||||
wrappedScalarA :: (MonadIO m, Aeson.ToJSON a)
|
wrappedScalar ::
|
||||||
=> Name -> ([Argument] -> ActionT m (Type.Wrapping a)) -> Resolver m
|
(Monad m, Aeson.ToJSON a) =>
|
||||||
wrappedScalarA name f = Resolver name $ resolveFieldValue f resolveRight
|
Name ->
|
||||||
|
ActionT m (Type.Wrapping a) ->
|
||||||
|
Resolver m
|
||||||
|
wrappedScalar name f = Resolver name $ resolveFieldValue f resolveRight
|
||||||
where
|
where
|
||||||
resolveRight fld (Type.Named result) = withField (return result) fld
|
resolveRight fld (Type.Named result) = withField (return result) fld
|
||||||
resolveRight fld Type.Null
|
resolveRight fld Type.Null
|
||||||
= return $ HashMap.singleton (aliasOrName fld) Aeson.Null
|
= return $ HashMap.singleton (aliasOrName fld) Aeson.Null
|
||||||
resolveRight fld (Type.List result) = withField (return result) fld
|
resolveRight fld (Type.List result) = withField (return result) fld
|
||||||
|
|
||||||
-- | Like 'scalar' but can be null or a list of scalars.
|
resolveFieldValue ::
|
||||||
wrappedScalar :: (MonadIO m, Aeson.ToJSON a)
|
Monad m =>
|
||||||
=> Name -> ActionT m (Type.Wrapping a) -> Resolver m
|
ActionT m a ->
|
||||||
wrappedScalar name = wrappedScalarA name . const
|
(Field -> a -> CollectErrsT m Aeson.Object) ->
|
||||||
|
Field ->
|
||||||
resolveFieldValue :: MonadIO m
|
CollectErrsT m (HashMap Text Aeson.Value)
|
||||||
=> ([Argument] -> ActionT m a)
|
|
||||||
-> (Field -> a -> CollectErrsT m (HashMap Text Aeson.Value))
|
|
||||||
-> Field
|
|
||||||
-> CollectErrsT m (HashMap Text Aeson.Value)
|
|
||||||
resolveFieldValue f resolveRight fld@(Field _ _ args _) = do
|
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
|
either resolveLeft (resolveRight fld) result
|
||||||
where
|
where
|
||||||
reader = flip runReaderT $ Context mempty
|
reader = flip runReaderT $ Context {arguments=args}
|
||||||
resolveLeft err = do
|
resolveLeft err = do
|
||||||
_ <- addErrMsg err
|
_ <- addErrMsg err
|
||||||
return $ HashMap.singleton (aliasOrName fld) Aeson.Null
|
return $ HashMap.singleton (aliasOrName fld) Aeson.Null
|
||||||
|
|
||||||
-- | Helper function to facilitate 'Argument' handling.
|
-- | Helper function to facilitate error handling and result emitting.
|
||||||
withField :: (MonadIO m, Aeson.ToJSON a)
|
withField :: (Monad m, Aeson.ToJSON a)
|
||||||
=> CollectErrsT m a -> Field -> CollectErrsT m (HashMap Text Aeson.Value)
|
=> CollectErrsT m a -> Field -> CollectErrsT m (HashMap Text Aeson.Value)
|
||||||
withField v fld
|
withField v fld
|
||||||
= HashMap.singleton (aliasOrName fld) . Aeson.toJSON <$> runAppendErrs v
|
= 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
|
-- | 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
|
-- 'Resolver' to each 'Field'. Resolves into a value containing the
|
||||||
-- resolved 'Field', or a null value and error information.
|
-- resolved 'Field', or a null value and error information.
|
||||||
resolve :: MonadIO m
|
resolve :: Monad m
|
||||||
=> [Resolver m] -> Seq Selection -> CollectErrsT m Aeson.Value
|
=> HashMap Text (Field -> CollectErrsT m Aeson.Object)
|
||||||
|
-> Seq Selection
|
||||||
|
-> CollectErrsT m Aeson.Value
|
||||||
resolve resolvers = fmap (Aeson.toJSON . fold) . traverse tryResolvers
|
resolve resolvers = fmap (Aeson.toJSON . fold) . traverse tryResolvers
|
||||||
where
|
where
|
||||||
resolveTypeName (Resolver "__typename" f) = do
|
resolveTypeName f = do
|
||||||
value <- f $ Field Nothing "__typename" mempty mempty
|
value <- f $ Field Nothing "__typename" mempty mempty
|
||||||
return $ HashMap.lookupDefault "" "__typename" value
|
return $ HashMap.lookupDefault "" "__typename" value
|
||||||
resolveTypeName _ = return ""
|
|
||||||
tryResolvers (SelectionField fld@(Field _ name _ _))
|
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
|
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
|
if maybe True (Aeson.String typeCondition ==) that
|
||||||
then fmap fold . traverse tryResolvers $ selections'
|
then fmap fold . traverse tryResolvers $ selections'
|
||||||
else return mempty
|
else return mempty
|
||||||
compareResolvers name (Resolver name' _) = name == name'
|
|
||||||
tryResolver fld (Resolver _ resolver) = resolver fld
|
|
||||||
errmsg fld@(Field _ name _ _) = do
|
errmsg fld@(Field _ name _ _) = do
|
||||||
addErrMsg $ T.unwords ["field", name, "not resolved."]
|
addErrMsg $ T.unwords ["field", name, "not resolved."]
|
||||||
return $ HashMap.singleton (aliasOrName fld) Aeson.Null
|
return $ HashMap.singleton (aliasOrName fld) Aeson.Null
|
||||||
|
|
|
@ -1,7 +1,8 @@
|
||||||
-- | Monad transformer stack used by the @GraphQL@ resolvers.
|
-- | Monad transformer stack used by the @GraphQL@ resolvers.
|
||||||
module Language.GraphQL.Trans
|
module Language.GraphQL.Trans
|
||||||
( ActionT(..)
|
( ActionT(..)
|
||||||
, Context(Context)
|
, Context(..)
|
||||||
|
, argument
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Control.Applicative (Alternative(..))
|
import Control.Applicative (Alternative(..))
|
||||||
|
@ -9,13 +10,17 @@ import Control.Monad (MonadPlus(..))
|
||||||
import Control.Monad.IO.Class (MonadIO(..))
|
import Control.Monad.IO.Class (MonadIO(..))
|
||||||
import Control.Monad.Trans.Class (MonadTrans(..))
|
import Control.Monad.Trans.Class (MonadTrans(..))
|
||||||
import Control.Monad.Trans.Except (ExceptT)
|
import Control.Monad.Trans.Except (ExceptT)
|
||||||
import Control.Monad.Trans.Reader (ReaderT)
|
import Control.Monad.Trans.Reader (ReaderT, asks)
|
||||||
import Data.HashMap.Strict (HashMap)
|
import qualified Data.HashMap.Strict as HashMap
|
||||||
|
import Data.Maybe (fromMaybe)
|
||||||
import Data.Text (Text)
|
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.
|
-- | 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
|
-- | Monad transformer stack used by the resolvers to provide error handling
|
||||||
-- and resolution context (resolver arguments).
|
-- and resolution context (resolver arguments).
|
||||||
|
@ -47,3 +52,13 @@ instance Monad m => Alternative (ActionT m) where
|
||||||
instance Monad m => MonadPlus (ActionT m) where
|
instance Monad m => MonadPlus (ActionT m) where
|
||||||
mzero = empty
|
mzero = empty
|
||||||
mplus = (<|>)
|
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:
|
packages:
|
||||||
- .
|
- .
|
||||||
|
|
|
@ -6,37 +6,124 @@ module Language.GraphQL.AST.EncoderSpec
|
||||||
|
|
||||||
import Language.GraphQL.AST
|
import Language.GraphQL.AST
|
||||||
import Language.GraphQL.AST.Encoder
|
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 Text.RawString.QQ (r)
|
||||||
|
import Data.Text.Lazy (cons, toStrict, unpack)
|
||||||
|
|
||||||
spec :: Spec
|
spec :: Spec
|
||||||
spec = do
|
spec = do
|
||||||
describe "value" $ 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
|
context "minified" $ do
|
||||||
it "escapes \\" $
|
it "escapes \\" $
|
||||||
value minified (String "\\") `shouldBe` "\"\\\\\""
|
value minified (String "\\") `shouldBe` "\"\\\\\""
|
||||||
it "escapes quotes" $
|
it "escapes double quotes" $
|
||||||
value minified (String "\"") `shouldBe` "\"\\\"\""
|
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" $
|
it "escapes backspace" $
|
||||||
value minified (String "a\bc") `shouldBe` "\"a\\bc\""
|
value minified (String "a\bc") `shouldBe` "\"a\\bc\""
|
||||||
it "escapes Unicode" $
|
context "escapes Unicode for chars less than 0010" $ do
|
||||||
value minified (String "\0") `shouldBe` "\"\\u0000\""
|
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
|
context "pretty" $ do
|
||||||
it "uses strings for short string values" $
|
it "uses strings for short string values" $
|
||||||
value pretty (String "Short text") `shouldBe` "\"Short text\""
|
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")
|
value pretty (String "Line 1\nLine 2")
|
||||||
`shouldBe` "\"\"\"\n Line 1\n Line 2\n\"\"\""
|
`shouldBe` [r|"""
|
||||||
it "escapes \\ in short strings" $
|
Line 1
|
||||||
value pretty (String "\\") `shouldBe` "\"\\\\\""
|
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" $
|
describe "definition" $
|
||||||
it "indents block strings in arguments" $
|
it "indents block strings in arguments" $
|
||||||
let arguments = [Argument "message" (String "line1\nline2")]
|
let arguments = [Argument "message" (String "line1\nline2")]
|
||||||
field = Field Nothing "field" arguments [] []
|
field = Field Nothing "field" arguments [] []
|
||||||
set = OperationSelectionSet $ pure $ SelectionField field
|
operation = DefinitionOperation $ SelectionSet $ pure field
|
||||||
operation = DefinitionOperation set
|
|
||||||
in definition pretty operation `shouldBe` [r|{
|
in definition pretty operation `shouldBe` [r|{
|
||||||
field(message: """
|
field(message: """
|
||||||
line1
|
line1
|
||||||
|
|
|
@ -8,7 +8,7 @@ import Data.Text (Text)
|
||||||
import Data.Void (Void)
|
import Data.Void (Void)
|
||||||
import Language.GraphQL.AST.Lexer
|
import Language.GraphQL.AST.Lexer
|
||||||
import Test.Hspec (Spec, context, describe, it)
|
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.Megaparsec (ParseErrorBundle, parse)
|
||||||
import Text.RawString.QQ (r)
|
import Text.RawString.QQ (r)
|
||||||
|
|
||||||
|
@ -77,7 +77,7 @@ spec = describe "Lexer" $ do
|
||||||
parse spread "" "..." `shouldParse` "..."
|
parse spread "" "..." `shouldParse` "..."
|
||||||
parse colon "" ":" `shouldParse` ":"
|
parse colon "" ":" `shouldParse` ":"
|
||||||
parse equals "" "=" `shouldParse` "="
|
parse equals "" "=" `shouldParse` "="
|
||||||
parse at "" "@" `shouldParse` '@'
|
parse at "" "@" `shouldParse` "@"
|
||||||
runBetween brackets `shouldSucceedOn` "[]"
|
runBetween brackets `shouldSucceedOn` "[]"
|
||||||
runBetween braces `shouldSucceedOn` "{}"
|
runBetween braces `shouldSucceedOn` "{}"
|
||||||
parse pipe "" "|" `shouldParse` "|"
|
parse pipe "" "|" `shouldParse` "|"
|
||||||
|
@ -87,6 +87,13 @@ spec = describe "Lexer" $ do
|
||||||
parse blockString "" [r|""""""|] `shouldParse` ""
|
parse blockString "" [r|""""""|] `shouldParse` ""
|
||||||
it "lexes ampersand" $
|
it "lexes ampersand" $
|
||||||
parse amp "" "&" `shouldParse` "&"
|
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 () -> Parser ()) -> Text -> Either (ParseErrorBundle Text Void) ()
|
||||||
runBetween parser = parse (parser $ pure ()) ""
|
runBetween parser = parse (parser $ pure ()) ""
|
||||||
|
|
|
@ -4,9 +4,11 @@ module Language.GraphQL.AST.ParserSpec
|
||||||
( spec
|
( spec
|
||||||
) where
|
) where
|
||||||
|
|
||||||
|
import Data.List.NonEmpty (NonEmpty(..))
|
||||||
|
import Language.GraphQL.AST.Document
|
||||||
import Language.GraphQL.AST.Parser
|
import Language.GraphQL.AST.Parser
|
||||||
import Test.Hspec (Spec, describe, it)
|
import Test.Hspec (Spec, describe, it)
|
||||||
import Test.Hspec.Megaparsec (shouldSucceedOn)
|
import Test.Hspec.Megaparsec (shouldParse, shouldSucceedOn)
|
||||||
import Text.Megaparsec (parse)
|
import Text.Megaparsec (parse)
|
||||||
import Text.RawString.QQ (r)
|
import Text.RawString.QQ (r)
|
||||||
|
|
||||||
|
@ -28,17 +30,115 @@ spec = describe "Parser" $ do
|
||||||
it "accepts two required arguments" $
|
it "accepts two required arguments" $
|
||||||
parse document "" `shouldSucceedOn` [r|
|
parse document "" `shouldSucceedOn` [r|
|
||||||
mutation auth($username: String!, $password: String!){
|
mutation auth($username: String!, $password: String!){
|
||||||
test
|
test
|
||||||
}|]
|
}|]
|
||||||
|
|
||||||
it "accepts two string arguments" $
|
it "accepts two string arguments" $
|
||||||
parse document "" `shouldSucceedOn` [r|
|
parse document "" `shouldSucceedOn` [r|
|
||||||
mutation auth{
|
mutation auth{
|
||||||
test(username: "username", password: "password")
|
test(username: "username", password: "password")
|
||||||
}|]
|
}|]
|
||||||
|
|
||||||
it "accepts two block string arguments" $
|
it "accepts two block string arguments" $
|
||||||
parse document "" `shouldSucceedOn` [r|
|
parse document "" `shouldSucceedOn` [r|
|
||||||
mutation auth{
|
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
|
) where
|
||||||
|
|
||||||
import Data.Aeson (Value, object, (.=))
|
import Data.Aeson (Value, object, (.=))
|
||||||
|
import Data.HashMap.Strict (HashMap)
|
||||||
|
import qualified Data.HashMap.Strict as HashMap
|
||||||
import Data.List.NonEmpty (NonEmpty(..))
|
import Data.List.NonEmpty (NonEmpty(..))
|
||||||
|
import Data.Text (Text)
|
||||||
import Language.GraphQL
|
import Language.GraphQL
|
||||||
import qualified Language.GraphQL.Schema as Schema
|
import qualified Language.GraphQL.Schema as Schema
|
||||||
import Test.Hspec (Spec, describe, it, shouldBe)
|
import Test.Hspec (Spec, describe, it, shouldBe)
|
||||||
import Text.RawString.QQ (r)
|
import Text.RawString.QQ (r)
|
||||||
|
|
||||||
experimentalResolver :: Schema.Resolver IO
|
experimentalResolver :: HashMap Text (NonEmpty (Schema.Resolver IO))
|
||||||
experimentalResolver = Schema.scalar "experimentalField" $ pure (5 :: Int)
|
experimentalResolver = HashMap.singleton "Query"
|
||||||
|
$ Schema.scalar "experimentalField" (pure (5 :: Int)) :| []
|
||||||
|
|
||||||
emptyObject :: Value
|
emptyObject :: Value
|
||||||
emptyObject = object
|
emptyObject = object
|
||||||
|
@ -29,7 +33,7 @@ spec =
|
||||||
}
|
}
|
||||||
|]
|
|]
|
||||||
|
|
||||||
actual <- graphql (experimentalResolver :| []) query
|
actual <- graphql experimentalResolver query
|
||||||
actual `shouldBe` emptyObject
|
actual `shouldBe` emptyObject
|
||||||
|
|
||||||
it "should not skip fields if @skip is false" $ do
|
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
|
actual `shouldBe` expected
|
||||||
|
|
||||||
it "should skip fields if @include is false" $ do
|
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
|
actual `shouldBe` emptyObject
|
||||||
|
|
||||||
it "should be able to @skip a fragment spread" $ do
|
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
|
actual `shouldBe` emptyObject
|
||||||
|
|
||||||
it "should be able to @skip an inline fragment" $ do
|
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
|
actual `shouldBe` emptyObject
|
||||||
|
|
|
@ -51,7 +51,7 @@ spec :: Spec
|
||||||
spec = do
|
spec = do
|
||||||
describe "Inline fragment executor" $ do
|
describe "Inline fragment executor" $ do
|
||||||
it "chooses the first selection if the type matches" $ 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
|
let expected = object
|
||||||
[ "data" .= object
|
[ "data" .= object
|
||||||
[ "garment" .= object
|
[ "garment" .= object
|
||||||
|
@ -62,7 +62,7 @@ spec = do
|
||||||
in actual `shouldBe` expected
|
in actual `shouldBe` expected
|
||||||
|
|
||||||
it "chooses the last selection if the type matches" $ do
|
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
|
let expected = object
|
||||||
[ "data" .= object
|
[ "data" .= object
|
||||||
[ "garment" .= object
|
[ "garment" .= object
|
||||||
|
@ -83,7 +83,7 @@ spec = do
|
||||||
}|]
|
}|]
|
||||||
resolvers = Schema.object "garment" $ return [circumference, size]
|
resolvers = Schema.object "garment" $ return [circumference, size]
|
||||||
|
|
||||||
actual <- graphql (resolvers :| []) query
|
actual <- graphql (HashMap.singleton "Query" $ resolvers :| []) query
|
||||||
let expected = object
|
let expected = object
|
||||||
[ "data" .= object
|
[ "data" .= object
|
||||||
[ "garment" .= object
|
[ "garment" .= object
|
||||||
|
@ -101,7 +101,7 @@ spec = do
|
||||||
}
|
}
|
||||||
}|]
|
}|]
|
||||||
|
|
||||||
actual <- graphql (size :| []) query
|
actual <- graphql (HashMap.singleton "Query" $ size :| []) query
|
||||||
actual `shouldNotSatisfy` hasErrors
|
actual `shouldNotSatisfy` hasErrors
|
||||||
|
|
||||||
describe "Fragment spread executor" $ do
|
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
|
let expected = object
|
||||||
[ "data" .= object
|
[ "data" .= object
|
||||||
[ "circumference" .= (60 :: Int)
|
[ "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
|
let expected = object
|
||||||
[ "data" .= object
|
[ "data" .= object
|
||||||
[ "garment" .= object
|
[ "garment" .= object
|
||||||
|
@ -162,7 +162,7 @@ spec = do
|
||||||
}
|
}
|
||||||
|]
|
|]
|
||||||
|
|
||||||
actual <- graphql (circumference :| []) query
|
actual <- graphql (HashMap.singleton "Query" $ circumference :| []) query
|
||||||
actual `shouldSatisfy` hasErrors
|
actual `shouldSatisfy` hasErrors
|
||||||
|
|
||||||
it "considers type condition" $ do
|
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
|
actual `shouldBe` expected
|
||||||
|
|
|
@ -8,7 +8,6 @@ module Test.StarWars.Data
|
||||||
, getEpisode
|
, getEpisode
|
||||||
, getFriends
|
, getFriends
|
||||||
, getHero
|
, getHero
|
||||||
, getHeroIO
|
|
||||||
, getHuman
|
, getHuman
|
||||||
, id_
|
, id_
|
||||||
, homePlanet
|
, homePlanet
|
||||||
|
@ -17,11 +16,8 @@ module Test.StarWars.Data
|
||||||
, typeName
|
, typeName
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Data.Monoid (mempty)
|
import Data.Functor.Identity (Identity)
|
||||||
import Control.Applicative ( Alternative(..)
|
import Control.Applicative (Alternative(..), liftA2)
|
||||||
, liftA2
|
|
||||||
)
|
|
||||||
import Control.Monad.IO.Class (MonadIO(..))
|
|
||||||
import Control.Monad.Trans.Except (throwE)
|
import Control.Monad.Trans.Except (throwE)
|
||||||
import Data.Maybe (catMaybes)
|
import Data.Maybe (catMaybes)
|
||||||
import Data.Text (Text)
|
import Data.Text (Text)
|
||||||
|
@ -71,7 +67,7 @@ appearsIn :: Character -> [Int]
|
||||||
appearsIn (Left x) = _appearsIn . _droidChar $ x
|
appearsIn (Left x) = _appearsIn . _droidChar $ x
|
||||||
appearsIn (Right x) = _appearsIn . _humanChar $ 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."
|
secretBackstory = const $ ActionT $ throwE "secretBackstory is secret."
|
||||||
|
|
||||||
typeName :: Character -> Text
|
typeName :: Character -> Text
|
||||||
|
@ -166,9 +162,6 @@ getHero :: Int -> Character
|
||||||
getHero 5 = luke
|
getHero 5 = luke
|
||||||
getHero _ = artoo
|
getHero _ = artoo
|
||||||
|
|
||||||
getHeroIO :: Int -> IO Character
|
|
||||||
getHeroIO = pure . getHero
|
|
||||||
|
|
||||||
getHuman :: Alternative f => ID -> f Character
|
getHuman :: Alternative f => ID -> f Character
|
||||||
getHuman = fmap Right . getHuman'
|
getHuman = fmap Right . getHuman'
|
||||||
|
|
||||||
|
|
|
@ -5,20 +5,15 @@ module Test.StarWars.QuerySpec
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import qualified Data.Aeson as Aeson
|
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 Data.Text (Text)
|
||||||
import Language.GraphQL
|
import Language.GraphQL
|
||||||
import Language.GraphQL.Schema (Subs)
|
import Language.GraphQL.Schema (Subs)
|
||||||
import Text.RawString.QQ (r)
|
import Text.RawString.QQ (r)
|
||||||
import Test.Hspec.Expectations ( Expectation
|
import Test.Hspec.Expectations (Expectation, shouldBe)
|
||||||
, shouldBe
|
import Test.Hspec (Spec, describe, it)
|
||||||
)
|
|
||||||
import Test.Hspec ( Spec
|
|
||||||
, describe
|
|
||||||
, it
|
|
||||||
)
|
|
||||||
import Test.StarWars.Schema
|
import Test.StarWars.Schema
|
||||||
|
|
||||||
-- * Test
|
-- * 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
|
it "R2-D2 ID and friends" $ testQuery
|
||||||
[r| query HeroNameAndFriendsQuery {
|
[r| query HeroNameAndFriendsQuery {
|
||||||
hero {
|
hero {
|
||||||
|
@ -46,14 +45,14 @@ spec = describe "Star Wars Query Tests" $ do
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|]
|
|]
|
||||||
$ object [ "data" .= object [
|
$ Aeson.object [ "data" .= Aeson.object [
|
||||||
"hero" .= object
|
"hero" .= Aeson.object
|
||||||
[ "id" .= ("2001" :: Text)
|
[ "id" .= ("2001" :: Text)
|
||||||
, r2d2Name
|
, r2d2Name
|
||||||
, "friends" .=
|
, "friends" .=
|
||||||
[ object [lukeName]
|
[ Aeson.object [lukeName]
|
||||||
, object [hanName]
|
, Aeson.object [hanName]
|
||||||
, object [leiaName]
|
, Aeson.object [leiaName]
|
||||||
]
|
]
|
||||||
]
|
]
|
||||||
]]
|
]]
|
||||||
|
@ -73,37 +72,37 @@ spec = describe "Star Wars Query Tests" $ do
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|]
|
|]
|
||||||
$ object [ "data" .= object [
|
$ Aeson.object [ "data" .= Aeson.object [
|
||||||
"hero" .= object [
|
"hero" .= Aeson.object [
|
||||||
"name" .= ("R2-D2" :: Text)
|
"name" .= ("R2-D2" :: Text)
|
||||||
, "friends" .= [
|
, "friends" .= [
|
||||||
object [
|
Aeson.object [
|
||||||
"name" .= ("Luke Skywalker" :: Text)
|
"name" .= ("Luke Skywalker" :: Text)
|
||||||
, "appearsIn" .= ["NEWHOPE","EMPIRE","JEDI" :: Text]
|
, "appearsIn" .= ["NEWHOPE","EMPIRE","JEDI" :: Text]
|
||||||
, "friends" .= [
|
, "friends" .= [
|
||||||
object [hanName]
|
Aeson.object [hanName]
|
||||||
, object [leiaName]
|
, Aeson.object [leiaName]
|
||||||
, object [c3poName]
|
, Aeson.object [c3poName]
|
||||||
, object [r2d2Name]
|
, Aeson.object [r2d2Name]
|
||||||
]
|
]
|
||||||
]
|
]
|
||||||
, object [
|
, Aeson.object [
|
||||||
hanName
|
hanName
|
||||||
, "appearsIn" .= [ "NEWHOPE","EMPIRE","JEDI" :: Text]
|
, "appearsIn" .= [ "NEWHOPE","EMPIRE","JEDI" :: Text]
|
||||||
, "friends" .= [
|
, "friends" .=
|
||||||
object [lukeName]
|
[ Aeson.object [lukeName]
|
||||||
, object [leiaName]
|
, Aeson.object [leiaName]
|
||||||
, object [r2d2Name]
|
, Aeson.object [r2d2Name]
|
||||||
]
|
]
|
||||||
]
|
]
|
||||||
, object [
|
, Aeson.object [
|
||||||
leiaName
|
leiaName
|
||||||
, "appearsIn" .= [ "NEWHOPE","EMPIRE","JEDI" :: Text]
|
, "appearsIn" .= [ "NEWHOPE","EMPIRE","JEDI" :: Text]
|
||||||
, "friends" .= [
|
, "friends" .=
|
||||||
object [lukeName]
|
[ Aeson.object [lukeName]
|
||||||
, object [hanName]
|
, Aeson.object [hanName]
|
||||||
, object [c3poName]
|
, Aeson.object [c3poName]
|
||||||
, object [r2d2Name]
|
, Aeson.object [r2d2Name]
|
||||||
]
|
]
|
||||||
]
|
]
|
||||||
]
|
]
|
||||||
|
@ -116,40 +115,40 @@ spec = describe "Star Wars Query Tests" $ do
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|]
|
|]
|
||||||
$ object [ "data" .= object [
|
$ Aeson.object [ "data" .= Aeson.object
|
||||||
"human" .= object [lukeName]
|
[ "human" .= Aeson.object [lukeName]
|
||||||
]]
|
]]
|
||||||
|
|
||||||
it "Luke ID with variable" $ testQueryParams
|
it "Luke ID with variable" $ testQueryParams
|
||||||
(\v -> if v == "someId" then Just "1000" else Nothing)
|
(HashMap.singleton "someId" "1000")
|
||||||
[r| query FetchSomeIDQuery($someId: String!) {
|
[r| query FetchSomeIDQuery($someId: String!) {
|
||||||
human(id: $someId) {
|
human(id: $someId) {
|
||||||
name
|
name
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|]
|
|]
|
||||||
$ object [ "data" .= object [
|
$ Aeson.object [ "data" .= Aeson.object [
|
||||||
"human" .= object [lukeName]
|
"human" .= Aeson.object [lukeName]
|
||||||
]]
|
]]
|
||||||
it "Han ID with variable" $ testQueryParams
|
it "Han ID with variable" $ testQueryParams
|
||||||
(\v -> if v == "someId" then Just "1002" else Nothing)
|
(HashMap.singleton "someId" "1002")
|
||||||
[r| query FetchSomeIDQuery($someId: String!) {
|
[r| query FetchSomeIDQuery($someId: String!) {
|
||||||
human(id: $someId) {
|
human(id: $someId) {
|
||||||
name
|
name
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|]
|
|]
|
||||||
$ object [ "data" .= object [
|
$ Aeson.object [ "data" .= Aeson.object [
|
||||||
"human" .= object [hanName]
|
"human" .= Aeson.object [hanName]
|
||||||
]]
|
]]
|
||||||
it "Invalid ID" $ testQueryParams
|
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!) {
|
[r| query humanQuery($id: String!) {
|
||||||
human(id: $id) {
|
human(id: $id) {
|
||||||
name
|
name
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|] $ object ["data" .= object ["human" .= Aeson.Null]]
|
|] $ Aeson.object ["data" .= Aeson.object ["human" .= Aeson.Null]]
|
||||||
it "Luke aliased" $ testQuery
|
it "Luke aliased" $ testQuery
|
||||||
[r| query FetchLukeAliased {
|
[r| query FetchLukeAliased {
|
||||||
luke: human(id: "1000") {
|
luke: human(id: "1000") {
|
||||||
|
@ -157,8 +156,8 @@ spec = describe "Star Wars Query Tests" $ do
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|]
|
|]
|
||||||
$ object [ "data" .= object [
|
$ Aeson.object [ "data" .= Aeson.object [
|
||||||
"luke" .= object [lukeName]
|
"luke" .= Aeson.object [lukeName]
|
||||||
]]
|
]]
|
||||||
it "R2-D2 ID and friends aliased" $ testQuery
|
it "R2-D2 ID and friends aliased" $ testQuery
|
||||||
[r| query HeroNameAndFriendsQuery {
|
[r| query HeroNameAndFriendsQuery {
|
||||||
|
@ -171,14 +170,14 @@ spec = describe "Star Wars Query Tests" $ do
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|]
|
|]
|
||||||
$ object [ "data" .= object [
|
$ Aeson.object [ "data" .= Aeson.object [
|
||||||
"hero" .= object [
|
"hero" .= Aeson.object [
|
||||||
"id" .= ("2001" :: Text)
|
"id" .= ("2001" :: Text)
|
||||||
, r2d2Name
|
, r2d2Name
|
||||||
, "friends" .= [
|
, "friends" .=
|
||||||
object ["friendName" .= ("Luke Skywalker" :: Text)]
|
[ Aeson.object ["friendName" .= ("Luke Skywalker" :: Text)]
|
||||||
, object ["friendName" .= ("Han Solo" :: Text)]
|
, Aeson.object ["friendName" .= ("Han Solo" :: Text)]
|
||||||
, object ["friendName" .= ("Leia Organa" :: Text)]
|
, Aeson.object ["friendName" .= ("Leia Organa" :: Text)]
|
||||||
]
|
]
|
||||||
]
|
]
|
||||||
]]
|
]]
|
||||||
|
@ -192,9 +191,9 @@ spec = describe "Star Wars Query Tests" $ do
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|]
|
|]
|
||||||
$ object [ "data" .= object [
|
$ Aeson.object [ "data" .= Aeson.object
|
||||||
"luke" .= object [lukeName]
|
[ "luke" .= Aeson.object [lukeName]
|
||||||
, "leia" .= object [leiaName]
|
, "leia" .= Aeson.object [leiaName]
|
||||||
]]
|
]]
|
||||||
|
|
||||||
describe "Fragments for complex queries" $ do
|
describe "Fragments for complex queries" $ do
|
||||||
|
@ -210,9 +209,9 @@ spec = describe "Star Wars Query Tests" $ do
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|]
|
|]
|
||||||
$ object [ "data" .= object [
|
$ Aeson.object [ "data" .= Aeson.object [
|
||||||
"luke" .= object [lukeName, tatooine]
|
"luke" .= Aeson.object [lukeName, tatooine]
|
||||||
, "leia" .= object [leiaName, alderaan]
|
, "leia" .= Aeson.object [leiaName, alderaan]
|
||||||
]]
|
]]
|
||||||
it "Fragment for duplicate content" $ testQuery
|
it "Fragment for duplicate content" $ testQuery
|
||||||
[r| query UseFragment {
|
[r| query UseFragment {
|
||||||
|
@ -228,9 +227,9 @@ spec = describe "Star Wars Query Tests" $ do
|
||||||
homePlanet
|
homePlanet
|
||||||
}
|
}
|
||||||
|]
|
|]
|
||||||
$ object [ "data" .= object [
|
$ Aeson.object [ "data" .= Aeson.object [
|
||||||
"luke" .= object [lukeName, tatooine]
|
"luke" .= Aeson.object [lukeName, tatooine]
|
||||||
, "leia" .= object [leiaName, alderaan]
|
, "leia" .= Aeson.object [leiaName, alderaan]
|
||||||
]]
|
]]
|
||||||
|
|
||||||
describe "__typename" $ do
|
describe "__typename" $ do
|
||||||
|
@ -242,8 +241,11 @@ spec = describe "Star Wars Query Tests" $ do
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|]
|
|]
|
||||||
$ object ["data" .= object [
|
$ Aeson.object ["data" .= Aeson.object [
|
||||||
"hero" .= object ["__typename" .= ("Droid" :: Text), r2d2Name]
|
"hero" .= Aeson.object
|
||||||
|
[ "__typename" .= ("Droid" :: Text)
|
||||||
|
, r2d2Name
|
||||||
|
]
|
||||||
]]
|
]]
|
||||||
it "Luke is a human" $ testQuery
|
it "Luke is a human" $ testQuery
|
||||||
[r| query CheckTypeOfLuke {
|
[r| query CheckTypeOfLuke {
|
||||||
|
@ -253,8 +255,11 @@ spec = describe "Star Wars Query Tests" $ do
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|]
|
|]
|
||||||
$ object ["data" .= object [
|
$ Aeson.object ["data" .= Aeson.object [
|
||||||
"hero" .= object ["__typename" .= ("Human" :: Text), lukeName]
|
"hero" .= Aeson.object
|
||||||
|
[ "__typename" .= ("Human" :: Text)
|
||||||
|
, lukeName
|
||||||
|
]
|
||||||
]]
|
]]
|
||||||
|
|
||||||
describe "Errors in resolvers" $ do
|
describe "Errors in resolvers" $ do
|
||||||
|
@ -267,15 +272,15 @@ spec = describe "Star Wars Query Tests" $ do
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|]
|
|]
|
||||||
$ object
|
$ Aeson.object
|
||||||
[ "data" .= object
|
[ "data" .= Aeson.object
|
||||||
[ "hero" .= object
|
[ "hero" .= Aeson.object
|
||||||
[ "name" .= ("R2-D2" :: Text)
|
[ "name" .= ("R2-D2" :: Text)
|
||||||
, "secretBackstory" .= Aeson.Null
|
, "secretBackstory" .= Aeson.Null
|
||||||
]
|
]
|
||||||
]
|
]
|
||||||
, "errors" .=
|
, "errors" .=
|
||||||
[ object
|
[ Aeson.object
|
||||||
["message" .= ("secretBackstory is secret." :: Text)]
|
["message" .= ("secretBackstory is secret." :: Text)]
|
||||||
]
|
]
|
||||||
]
|
]
|
||||||
|
@ -290,19 +295,19 @@ spec = describe "Star Wars Query Tests" $ do
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|]
|
|]
|
||||||
$ object ["data" .= object
|
$ Aeson.object ["data" .= Aeson.object
|
||||||
[ "hero" .= object
|
[ "hero" .= Aeson.object
|
||||||
[ "name" .= ("R2-D2" :: Text)
|
[ "name" .= ("R2-D2" :: Text)
|
||||||
, "friends" .=
|
, "friends" .=
|
||||||
[ object
|
[ Aeson.object
|
||||||
[ "name" .= ("Luke Skywalker" :: Text)
|
[ "name" .= ("Luke Skywalker" :: Text)
|
||||||
, "secretBackstory" .= Aeson.Null
|
, "secretBackstory" .= Aeson.Null
|
||||||
]
|
]
|
||||||
, object
|
, Aeson.object
|
||||||
[ "name" .= ("Han Solo" :: Text)
|
[ "name" .= ("Han Solo" :: Text)
|
||||||
, "secretBackstory" .= Aeson.Null
|
, "secretBackstory" .= Aeson.Null
|
||||||
]
|
]
|
||||||
, object
|
, Aeson.object
|
||||||
[ "name" .= ("Leia Organa" :: Text)
|
[ "name" .= ("Leia Organa" :: Text)
|
||||||
, "secretBackstory" .= Aeson.Null
|
, "secretBackstory" .= Aeson.Null
|
||||||
]
|
]
|
||||||
|
@ -310,9 +315,15 @@ spec = describe "Star Wars Query Tests" $ do
|
||||||
]
|
]
|
||||||
]
|
]
|
||||||
, "errors" .=
|
, "errors" .=
|
||||||
[ object ["message" .= ("secretBackstory is secret." :: Text)]
|
[ Aeson.object
|
||||||
, object ["message" .= ("secretBackstory is secret." :: Text)]
|
[ "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)
|
||||||
|
]
|
||||||
]
|
]
|
||||||
]
|
]
|
||||||
it "error on secretBackstory with alias" $ testQuery
|
it "error on secretBackstory with alias" $ testQuery
|
||||||
|
@ -323,15 +334,17 @@ spec = describe "Star Wars Query Tests" $ do
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|]
|
|]
|
||||||
$ object
|
$ Aeson.object
|
||||||
[ "data" .= object
|
[ "data" .= Aeson.object
|
||||||
[ "mainHero" .= object
|
[ "mainHero" .= Aeson.object
|
||||||
[ "name" .= ("R2-D2" :: Text)
|
[ "name" .= ("R2-D2" :: Text)
|
||||||
, "story" .= Aeson.Null
|
, "story" .= Aeson.Null
|
||||||
]
|
]
|
||||||
]
|
]
|
||||||
, "errors" .=
|
, "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)
|
alderaan = "homePlanet" .= ("Alderaan" :: Text)
|
||||||
|
|
||||||
testQuery :: Text -> Aeson.Value -> Expectation
|
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 :: 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 #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
module Test.StarWars.Schema
|
module Test.StarWars.Schema
|
||||||
( character
|
( character
|
||||||
|
@ -10,9 +9,12 @@ module Test.StarWars.Schema
|
||||||
|
|
||||||
import Control.Monad.Trans.Except (throwE)
|
import Control.Monad.Trans.Except (throwE)
|
||||||
import Control.Monad.Trans.Class (lift)
|
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.List.NonEmpty (NonEmpty(..))
|
||||||
import Data.Maybe (catMaybes)
|
import Data.Maybe (catMaybes)
|
||||||
|
import Data.Text (Text)
|
||||||
import qualified Language.GraphQL.Schema as Schema
|
import qualified Language.GraphQL.Schema as Schema
|
||||||
import Language.GraphQL.Trans
|
import Language.GraphQL.Trans
|
||||||
import qualified Language.GraphQL.Type as Type
|
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
|
-- See https://github.com/graphql/graphql-js/blob/master/src/__tests__/starWarsSchema.js
|
||||||
|
|
||||||
schema :: MonadIO m => NonEmpty (Schema.Resolver m)
|
schema :: HashMap Text (NonEmpty (Schema.Resolver Identity))
|
||||||
schema = hero :| [human, droid]
|
schema = HashMap.singleton "Query" $ hero :| [human, droid]
|
||||||
|
|
||||||
hero :: MonadIO m => Schema.Resolver m
|
hero :: Schema.Resolver Identity
|
||||||
hero = Schema.objectA "hero" $ \case
|
hero = Schema.object "hero" $ do
|
||||||
[] -> character artoo
|
episode <- argument "episode"
|
||||||
[Schema.Argument "episode" (Schema.Enum "NEWHOPE")] -> character $ getHero 4
|
character $ case episode of
|
||||||
[Schema.Argument "episode" (Schema.Enum "EMPIRE" )] -> character $ getHero 5
|
Schema.Enum "NEWHOPE" -> getHero 4
|
||||||
[Schema.Argument "episode" (Schema.Enum "JEDI" )] -> character $ getHero 6
|
Schema.Enum "EMPIRE" -> getHero 5
|
||||||
_ -> ActionT $ throwE "Invalid arguments."
|
Schema.Enum "JEDI" -> getHero 6
|
||||||
|
_ -> artoo
|
||||||
|
|
||||||
human :: MonadIO m => Schema.Resolver m
|
human :: Schema.Resolver Identity
|
||||||
human = Schema.wrappedObjectA "human" $ \case
|
human = Schema.wrappedObject "human" $ do
|
||||||
[Schema.Argument "id" (Schema.String i)] -> do
|
id' <- argument "id"
|
||||||
humanCharacter <- lift $ return $ getHuman i >>= Just
|
case id' of
|
||||||
case humanCharacter of
|
Schema.String i -> do
|
||||||
Nothing -> return Type.Null
|
humanCharacter <- lift $ return $ getHuman i >>= Just
|
||||||
Just e -> Type.Named <$> character e
|
case humanCharacter of
|
||||||
_ -> ActionT $ throwE "Invalid arguments."
|
Nothing -> return Type.Null
|
||||||
|
Just e -> Type.Named <$> character e
|
||||||
|
_ -> ActionT $ throwE "Invalid arguments."
|
||||||
|
|
||||||
droid :: MonadIO m => Schema.Resolver m
|
droid :: Schema.Resolver Identity
|
||||||
droid = Schema.objectA "droid" $ \case
|
droid = Schema.object "droid" $ do
|
||||||
[Schema.Argument "id" (Schema.String i)] -> character =<< liftIO (getDroid i)
|
id' <- argument "id"
|
||||||
_ -> ActionT $ throwE "Invalid arguments."
|
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
|
character char = return
|
||||||
[ Schema.scalar "id" $ return $ id_ char
|
[ Schema.scalar "id" $ return $ id_ char
|
||||||
, Schema.scalar "name" $ return $ name char
|
, Schema.scalar "name" $ return $ name char
|
||||||
|
|
Loading…
Reference in New Issue