Compare commits
11 Commits
Author | SHA1 | Date |
---|---|---|
Eugen Wissner | 75bc3b8509 | |
Eugen Wissner | c7d5b02911 | |
Eugen Wissner | 37254c8c95 | |
Eugen Wissner | 856efc5d25 | |
Eugen Wissner | b2a9ec7d82 | |
Eugen Wissner | 0d142fb01c | |
Eugen Wissner | f767f6cd40 | |
Eugen Wissner | eb98c36258 | |
Eugen Wissner | 70f7e1bd8e | |
Eugen Wissner | 2b5c719ab0 | |
Eugen Wissner | c075a41582 |
|
@ -8,3 +8,4 @@
|
|||
.cabal-sandbox/
|
||||
cabal.sandbox.config
|
||||
cabal.project.local
|
||||
/graphql.cabal
|
||||
|
|
18
CHANGELOG.md
18
CHANGELOG.md
|
@ -1,6 +1,23 @@
|
|||
# Change Log
|
||||
All notable changes to this project will be documented in this file.
|
||||
|
||||
## [0.5.1.0] - 2019-10-22
|
||||
### Deprecated
|
||||
- `Language.GraphQL.AST.Arguments`. Use `[Language.GraphQL.AST.Argument]`
|
||||
instead.
|
||||
- `Language.GraphQL.AST.Directives`. Use `[Language.GraphQL.AST.Directives]`
|
||||
instead.
|
||||
- `Language.GraphQL.AST.VariableDefinitions`. Use
|
||||
`[Language.GraphQL.AST.VariableDefinition]` instead.
|
||||
|
||||
### Added
|
||||
- Module documentation.
|
||||
- Inline fragment support.
|
||||
|
||||
### Fixed
|
||||
- Top-level fragments.
|
||||
- Fragment for execution is chosen based on the type.
|
||||
|
||||
## [0.5.0.1] - 2019-09-10
|
||||
### Added
|
||||
- Minimal documentation for all public symbols.
|
||||
|
@ -88,6 +105,7 @@ All notable changes to this project will be documented in this file.
|
|||
### Added
|
||||
- Data types for the GraphQL language.
|
||||
|
||||
[0.5.1.0]: https://github.com/caraus-ecms/graphql/compare/v0.5.0.1...v0.5.1.0
|
||||
[0.5.0.1]: https://github.com/caraus-ecms/graphql/compare/v0.5.0.0...v0.5.0.1
|
||||
[0.5.0.0]: https://github.com/caraus-ecms/graphql/compare/v0.4.0.0...v0.5.0.0
|
||||
[0.4.0.0]: https://github.com/caraus-ecms/graphql/compare/v0.3...v0.4.0.0
|
||||
|
|
|
@ -1,91 +0,0 @@
|
|||
cabal-version: 1.12
|
||||
|
||||
-- This file has been generated from package.yaml by hpack version 0.31.2.
|
||||
--
|
||||
-- see: https://github.com/sol/hpack
|
||||
--
|
||||
-- hash: 0b3b2cb6ec02a4eeaee98d4c003d4cbe68ab81fde1810b06b0b6eeb61010298c
|
||||
|
||||
name: graphql
|
||||
version: 0.5.0.1
|
||||
synopsis: Haskell GraphQL implementation
|
||||
description: This package provides a rudimentary parser for the <https://graphql.github.io/graphql-spec/June2018/ GraphQL> language.
|
||||
category: Language
|
||||
homepage: https://github.com/caraus-ecms/graphql#readme
|
||||
bug-reports: https://github.com/caraus-ecms/graphql/issues
|
||||
author: Danny Navarro <j@dannynavarro.net>,
|
||||
Matthías Páll Gissurarson <mpg@mpg.is>,
|
||||
Sólrún Halla Einarsdóttir <she@mpg.is>
|
||||
maintainer: belka@caraus.de
|
||||
copyright: (c) 2019 Eugen Wissner,
|
||||
(c) 2015-2017 J. Daniel Navarro
|
||||
license: BSD3
|
||||
license-file: LICENSE
|
||||
build-type: Simple
|
||||
extra-source-files:
|
||||
CHANGELOG.md
|
||||
README.md
|
||||
LICENSE
|
||||
docs/tutorial/tutorial.lhs
|
||||
data-files:
|
||||
tests/data/kitchen-sink.graphql
|
||||
tests/data/kitchen-sink.min.graphql
|
||||
|
||||
source-repository head
|
||||
type: git
|
||||
location: https://github.com/caraus-ecms/graphql
|
||||
|
||||
library
|
||||
exposed-modules:
|
||||
Language.GraphQL
|
||||
Language.GraphQL.AST
|
||||
Language.GraphQL.AST.Core
|
||||
Language.GraphQL.AST.Transform
|
||||
Language.GraphQL.Encoder
|
||||
Language.GraphQL.Error
|
||||
Language.GraphQL.Execute
|
||||
Language.GraphQL.Lexer
|
||||
Language.GraphQL.Parser
|
||||
Language.GraphQL.Schema
|
||||
Language.GraphQL.Trans
|
||||
Language.GraphQL.Type
|
||||
other-modules:
|
||||
Paths_graphql
|
||||
hs-source-dirs:
|
||||
src
|
||||
build-depends:
|
||||
aeson
|
||||
, base >=4.7 && <5
|
||||
, megaparsec
|
||||
, text
|
||||
, transformers
|
||||
, unordered-containers
|
||||
default-language: Haskell2010
|
||||
|
||||
test-suite tasty
|
||||
type: exitcode-stdio-1.0
|
||||
main-is: Spec.hs
|
||||
other-modules:
|
||||
Language.GraphQL.EncoderSpec
|
||||
Language.GraphQL.ErrorSpec
|
||||
Language.GraphQL.LexerSpec
|
||||
Language.GraphQL.ParserSpec
|
||||
Test.KitchenSinkSpec
|
||||
Test.StarWars.Data
|
||||
Test.StarWars.QuerySpec
|
||||
Test.StarWars.Schema
|
||||
Paths_graphql
|
||||
hs-source-dirs:
|
||||
tests
|
||||
ghc-options: -threaded -rtsopts -with-rtsopts=-N
|
||||
build-depends:
|
||||
aeson
|
||||
, base >=4.7 && <5
|
||||
, graphql
|
||||
, hspec
|
||||
, hspec-expectations
|
||||
, megaparsec
|
||||
, raw-strings-qq
|
||||
, text
|
||||
, transformers
|
||||
default-language: Haskell2010
|
|
@ -1,5 +1,5 @@
|
|||
name: graphql
|
||||
version: 0.5.0.1
|
||||
version: 0.5.1.0
|
||||
synopsis: Haskell GraphQL implementation
|
||||
description:
|
||||
This package provides a rudimentary parser for the
|
||||
|
@ -31,11 +31,10 @@ dependencies:
|
|||
- megaparsec
|
||||
- text
|
||||
- transformers
|
||||
- unordered-containers
|
||||
|
||||
library:
|
||||
source-dirs: src
|
||||
dependencies:
|
||||
- unordered-containers
|
||||
|
||||
tests:
|
||||
tasty:
|
||||
|
@ -49,4 +48,5 @@ tests:
|
|||
- graphql
|
||||
- hspec
|
||||
- hspec-expectations
|
||||
- hspec-megaparsec
|
||||
- raw-strings-qq
|
||||
|
|
|
@ -1,6 +1,7 @@
|
|||
#!/bin/bash
|
||||
|
||||
STACK=$SEMAPHORE_CACHE_DIR/stack
|
||||
export STACK_ROOT=$SEMAPHORE_CACHE_DIR/.stack
|
||||
|
||||
setup() {
|
||||
if [ ! -e "$STACK" ]
|
||||
|
@ -20,7 +21,7 @@ test() {
|
|||
|
||||
test_docs() {
|
||||
$STACK --no-terminal ghc -- -Wall -Werror -fno-code docs/tutorial/tutorial.lhs
|
||||
$STACK --no-terminal haddock --no-haddock-deps
|
||||
$STACK --no-terminal haddock --no-haddock-deps
|
||||
}
|
||||
|
||||
setup_lint() {
|
||||
|
|
|
@ -35,6 +35,7 @@ import Data.List.NonEmpty (NonEmpty)
|
|||
import Data.Text (Text)
|
||||
import Language.GraphQL.AST.Core ( Alias
|
||||
, Name
|
||||
, TypeCondition
|
||||
)
|
||||
|
||||
-- * Document
|
||||
|
@ -45,18 +46,20 @@ type Document = NonEmpty Definition
|
|||
-- * Operations
|
||||
|
||||
-- | Top-level definition of a document, either an operation or a fragment.
|
||||
data Definition = DefinitionOperation OperationDefinition
|
||||
| DefinitionFragment FragmentDefinition
|
||||
deriving (Eq, Show)
|
||||
data Definition
|
||||
= DefinitionOperation OperationDefinition
|
||||
| DefinitionFragment FragmentDefinition
|
||||
deriving (Eq, Show)
|
||||
|
||||
-- | Operation definition.
|
||||
data OperationDefinition = OperationSelectionSet SelectionSet
|
||||
| OperationDefinition OperationType
|
||||
(Maybe Name)
|
||||
VariableDefinitions
|
||||
Directives
|
||||
SelectionSet
|
||||
deriving (Eq, Show)
|
||||
data OperationDefinition
|
||||
= OperationSelectionSet SelectionSet
|
||||
| OperationDefinition OperationType
|
||||
(Maybe Name)
|
||||
[VariableDefinition]
|
||||
[Directive]
|
||||
SelectionSet
|
||||
deriving (Eq, Show)
|
||||
|
||||
-- | GraphQL has 3 operation types: queries, mutations and subscribtions.
|
||||
--
|
||||
|
@ -68,11 +71,12 @@ data OperationType = Query | Mutation deriving (Eq, Show)
|
|||
-- | "Top-level" selection, selection on a operation.
|
||||
type SelectionSet = NonEmpty Selection
|
||||
|
||||
-- | Field selection.
|
||||
type SelectionSetOpt = [Selection]
|
||||
|
||||
-- | Single selection element.
|
||||
data Selection
|
||||
= SelectionField Field
|
||||
= SelectionField Field
|
||||
| SelectionFragmentSpread FragmentSpread
|
||||
| SelectionInlineFragment InlineFragment
|
||||
deriving (Eq, Show)
|
||||
|
@ -81,12 +85,13 @@ data Selection
|
|||
|
||||
-- | GraphQL field.
|
||||
data Field
|
||||
= Field (Maybe Alias) Name Arguments Directives SelectionSetOpt
|
||||
= Field (Maybe Alias) Name [Argument] [Directive] SelectionSetOpt
|
||||
deriving (Eq, Show)
|
||||
|
||||
-- * Arguments
|
||||
|
||||
-- | Argument list.
|
||||
{-# DEPRECATED Arguments "Use [Argument] instead" #-}
|
||||
type Arguments = [Argument]
|
||||
|
||||
-- | Argument.
|
||||
|
@ -95,23 +100,20 @@ data Argument = Argument Name Value deriving (Eq,Show)
|
|||
-- * Fragments
|
||||
|
||||
-- | Fragment spread.
|
||||
data FragmentSpread = FragmentSpread Name Directives deriving (Eq, Show)
|
||||
data FragmentSpread = FragmentSpread Name [Directive] deriving (Eq, Show)
|
||||
|
||||
-- | Inline fragment.
|
||||
data InlineFragment = InlineFragment (Maybe TypeCondition) Directives SelectionSet
|
||||
data InlineFragment = InlineFragment (Maybe TypeCondition) [Directive] SelectionSet
|
||||
deriving (Eq, Show)
|
||||
|
||||
-- | Fragment definition.
|
||||
data FragmentDefinition
|
||||
= FragmentDefinition Name TypeCondition Directives SelectionSet
|
||||
= FragmentDefinition Name TypeCondition [Directive] SelectionSet
|
||||
deriving (Eq, Show)
|
||||
|
||||
{-# DEPRECATED FragmentName "Use Name instead" #-}
|
||||
type FragmentName = Name
|
||||
|
||||
-- | Type condition.
|
||||
type TypeCondition = Name
|
||||
|
||||
-- * Input values
|
||||
|
||||
-- | Input value.
|
||||
|
@ -134,6 +136,7 @@ data ObjectField = ObjectField Name Value deriving (Eq, Show)
|
|||
-- * Variables
|
||||
|
||||
-- | Variable definition list.
|
||||
{-# DEPRECATED VariableDefinitions "Use [VariableDefinition] instead" #-}
|
||||
type VariableDefinitions = [VariableDefinition]
|
||||
|
||||
-- | Variable definition.
|
||||
|
@ -157,6 +160,7 @@ data NonNullType = NonNullTypeNamed Name
|
|||
-- * Directives
|
||||
|
||||
-- | Directive list.
|
||||
{-# DEPRECATED Directives "Use [Directive] instead" #-}
|
||||
type Directives = [Directive]
|
||||
|
||||
-- | Directive.
|
||||
|
|
|
@ -4,16 +4,18 @@ module Language.GraphQL.AST.Core
|
|||
, Argument(..)
|
||||
, Document
|
||||
, Field(..)
|
||||
, Fragment(..)
|
||||
, Name
|
||||
, ObjectField(..)
|
||||
, Operation(..)
|
||||
, Selection(..)
|
||||
, TypeCondition
|
||||
, Value(..)
|
||||
) where
|
||||
|
||||
import Data.Int (Int32)
|
||||
import Data.List.NonEmpty (NonEmpty)
|
||||
import Data.String
|
||||
|
||||
import Data.Text (Text)
|
||||
|
||||
-- | Name
|
||||
|
@ -26,8 +28,8 @@ type Document = NonEmpty Operation
|
|||
--
|
||||
-- Currently only queries and mutations are supported.
|
||||
data Operation
|
||||
= Query (Maybe Text) (NonEmpty Field)
|
||||
| Mutation (Maybe Text) (NonEmpty Field)
|
||||
= Query (Maybe Text) (NonEmpty Selection)
|
||||
| Mutation (Maybe Text) (NonEmpty Selection)
|
||||
deriving (Eq, Show)
|
||||
|
||||
-- | A single GraphQL field.
|
||||
|
@ -51,7 +53,7 @@ data Operation
|
|||
-- * "zuck" is an alias for "user". "id" and "name" have no aliases.
|
||||
-- * "id: 4" is an argument for "name". "id" and "name don't have any
|
||||
-- arguments.
|
||||
data Field = Field (Maybe Alias) Name [Argument] [Field] deriving (Eq, Show)
|
||||
data Field = Field (Maybe Alias) Name [Argument] [Selection] deriving (Eq, Show)
|
||||
|
||||
-- | Alternative field name.
|
||||
--
|
||||
|
@ -100,3 +102,17 @@ instance IsString Value where
|
|||
--
|
||||
-- A list of 'ObjectField's represents a GraphQL object type.
|
||||
data ObjectField = ObjectField Name Value deriving (Eq, Show)
|
||||
|
||||
-- | Type condition.
|
||||
type TypeCondition = Name
|
||||
|
||||
-- | Represents fragments and inline fragments.
|
||||
data Fragment
|
||||
= Fragment TypeCondition (NonEmpty Selection)
|
||||
deriving (Eq, Show)
|
||||
|
||||
-- | Single selection element.
|
||||
data Selection
|
||||
= SelectionFragment Fragment
|
||||
| SelectionField Field
|
||||
deriving (Eq, Show)
|
||||
|
|
|
@ -1,21 +1,25 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
-- | After the document is parsed, before getting executed the AST is
|
||||
-- transformed into a similar, simpler AST. This module is responsible for
|
||||
-- this transformation.
|
||||
module Language.GraphQL.AST.Transform
|
||||
( document
|
||||
) where
|
||||
|
||||
import Control.Applicative (empty)
|
||||
import Control.Monad ((<=<))
|
||||
import Data.Bifunctor (first)
|
||||
import Data.Either (partitionEithers)
|
||||
import Data.Foldable (fold, foldMap)
|
||||
import Data.List.NonEmpty (NonEmpty)
|
||||
import qualified Data.List.NonEmpty as NonEmpty
|
||||
import Data.Monoid (Alt(Alt,getAlt), (<>))
|
||||
import qualified Language.GraphQL.AST as Full
|
||||
import qualified Language.GraphQL.AST.Core as Core
|
||||
import qualified Language.GraphQL.Schema as Schema
|
||||
|
||||
-- | Replaces a fragment name by a list of 'Field'. If the name doesn't match an
|
||||
-- empty list is returned.
|
||||
-- | Replaces a fragment name by a list of 'Core.Field'. If the name doesn't
|
||||
-- match an empty list is returned.
|
||||
type Fragmenter = Core.Name -> [Core.Field]
|
||||
|
||||
-- | Rewrites the original syntax tree into an intermediate representation used
|
||||
|
@ -40,34 +44,38 @@ operations
|
|||
-> Fragmenter
|
||||
-> [Full.OperationDefinition]
|
||||
-> Maybe Core.Document
|
||||
operations subs fr = NonEmpty.nonEmpty <=< traverse (operation subs fr)
|
||||
operations subs fr = NonEmpty.nonEmpty . fmap (operation subs fr)
|
||||
|
||||
operation
|
||||
:: Schema.Subs
|
||||
-> Fragmenter
|
||||
-> Full.OperationDefinition
|
||||
-> Maybe Core.Operation
|
||||
-> Core.Operation
|
||||
operation subs fr (Full.OperationSelectionSet sels) =
|
||||
operation subs fr $ Full.OperationDefinition Full.Query empty empty empty sels
|
||||
-- TODO: Validate Variable definitions with substituter
|
||||
operation subs fr (Full.OperationDefinition operationType name _vars _dirs sels)
|
||||
= case operationType of
|
||||
Full.Query -> Core.Query name <$> node
|
||||
Full.Mutation -> Core.Mutation name <$> node
|
||||
where
|
||||
node = traverse (hush . selection subs fr) sels
|
||||
operation subs fr (Full.OperationDefinition Full.Query name _vars _dirs sels) =
|
||||
Core.Query name $ appendSelection subs fr sels
|
||||
operation subs fr (Full.OperationDefinition Full.Mutation name _vars _dirs sels) =
|
||||
Core.Mutation name $ appendSelection subs fr sels
|
||||
|
||||
selection
|
||||
:: Schema.Subs
|
||||
-> Fragmenter
|
||||
-> Full.Selection
|
||||
-> Either [Core.Field] Core.Field
|
||||
selection subs fr (Full.SelectionField fld) =
|
||||
Right $ field subs fr fld
|
||||
selection _ fr (Full.SelectionFragmentSpread (Full.FragmentSpread n _dirs)) =
|
||||
Left $ fr n
|
||||
selection _ _ (Full.SelectionInlineFragment _) =
|
||||
error "Inline fragments not supported yet"
|
||||
-> Either [Core.Selection] Core.Selection
|
||||
selection subs fr (Full.SelectionField fld)
|
||||
= Right $ Core.SelectionField $ field subs fr fld
|
||||
selection _ fr (Full.SelectionFragmentSpread (Full.FragmentSpread name _))
|
||||
= Left $ Core.SelectionField <$> fr name
|
||||
selection subs fr (Full.SelectionInlineFragment fragment)
|
||||
| (Full.InlineFragment (Just typeCondition) _ selectionSet) <- fragment
|
||||
= Right
|
||||
$ Core.SelectionFragment
|
||||
$ Core.Fragment typeCondition
|
||||
$ appendSelection subs fr selectionSet
|
||||
| (Full.InlineFragment Nothing _ selectionSet) <- fragment
|
||||
= Left $ NonEmpty.toList $ appendSelection subs fr selectionSet
|
||||
|
||||
-- * Fragment replacement
|
||||
|
||||
|
@ -83,19 +91,22 @@ defrag subs (Full.DefinitionFragment fragDef) =
|
|||
Left $ fragmentDefinition subs fragDef
|
||||
|
||||
fragmentDefinition :: Schema.Subs -> Full.FragmentDefinition -> Fragmenter
|
||||
fragmentDefinition subs (Full.FragmentDefinition name _tc _dirs sels) name' =
|
||||
-- TODO: Support fragments within fragments. Fold instead of map.
|
||||
if name == name'
|
||||
then either id pure =<< NonEmpty.toList (selection subs mempty <$> sels)
|
||||
else empty
|
||||
fragmentDefinition subs (Full.FragmentDefinition name _tc _dirs sels) name'
|
||||
| name == name' = selection' <$> do
|
||||
selections <- NonEmpty.toList $ selection subs mempty <$> sels
|
||||
either id pure selections
|
||||
| otherwise = empty
|
||||
where
|
||||
selection' (Core.SelectionField field') = field'
|
||||
selection' _ = error "Fragments within fragments are not supported yet"
|
||||
|
||||
field :: Schema.Subs -> Fragmenter -> Full.Field -> Core.Field
|
||||
field subs fr (Full.Field a n args _dirs sels) =
|
||||
Core.Field a n (fold $ argument subs `traverse` args) (foldr go empty sels)
|
||||
where
|
||||
go :: Full.Selection -> [Core.Field] -> [Core.Field]
|
||||
go (Full.SelectionFragmentSpread (Full.FragmentSpread name _dirs)) = (fr name <>)
|
||||
go sel = (either id pure (selection subs fr sel) <>)
|
||||
go :: Full.Selection -> [Core.Selection] -> [Core.Selection]
|
||||
go (Full.SelectionFragmentSpread (Full.FragmentSpread name _dirs)) = ((Core.SelectionField <$> fr name) <>)
|
||||
go sel = (either id pure (selection subs fr sel) <>)
|
||||
|
||||
argument :: Schema.Subs -> Full.Argument -> Maybe Core.Argument
|
||||
argument subs (Full.Argument n v) = Core.Argument n <$> value subs v
|
||||
|
@ -116,5 +127,10 @@ value subs (Full.ValueObject o) =
|
|||
objectField :: Schema.Subs -> Full.ObjectField -> Maybe Core.ObjectField
|
||||
objectField subs (Full.ObjectField n v) = Core.ObjectField n <$> value subs v
|
||||
|
||||
hush :: Either a b -> Maybe b
|
||||
hush = either (const Nothing) Just
|
||||
appendSelection ::
|
||||
Schema.Subs ->
|
||||
Fragmenter ->
|
||||
NonEmpty Full.Selection ->
|
||||
NonEmpty Core.Selection
|
||||
appendSelection subs fr = NonEmpty.fromList
|
||||
. foldr (either (++) (:) . selection subs fr) []
|
||||
|
|
|
@ -31,11 +31,11 @@ data Formatter
|
|||
= Minified
|
||||
| Pretty Word
|
||||
|
||||
-- Constructs a formatter for pretty printing.
|
||||
-- | Constructs a formatter for pretty printing.
|
||||
pretty :: Formatter
|
||||
pretty = Pretty 0
|
||||
|
||||
-- Constructs a formatter for minifying.
|
||||
-- | Constructs a formatter for minifying.
|
||||
minified :: Formatter
|
||||
minified = Minified
|
||||
|
||||
|
@ -67,11 +67,11 @@ operationDefinition formatter (OperationDefinition Mutation name vars dirs sels)
|
|||
= "mutation " <> node formatter name vars dirs sels
|
||||
|
||||
node :: Formatter
|
||||
-> Maybe Name
|
||||
-> VariableDefinitions
|
||||
-> Directives
|
||||
-> SelectionSet
|
||||
-> Text
|
||||
-> Maybe Name
|
||||
-> [VariableDefinition]
|
||||
-> [Directive]
|
||||
-> SelectionSet
|
||||
-> Text
|
||||
node formatter name vars dirs sels
|
||||
= Text.Lazy.fromStrict (fold name)
|
||||
<> optempty (variableDefinitions formatter) vars
|
||||
|
@ -170,7 +170,7 @@ directive :: Formatter -> Directive -> Text
|
|||
directive formatter (Directive name args)
|
||||
= "@" <> Text.Lazy.fromStrict name <> optempty (arguments formatter) args
|
||||
|
||||
directives :: Formatter -> Directives -> Text
|
||||
directives :: Formatter -> [Directive] -> Text
|
||||
directives formatter@(Pretty _) = Text.Lazy.cons ' ' . spaces (directive formatter)
|
||||
directives Minified = spaces (directive Minified)
|
||||
|
||||
|
|
|
@ -1,5 +1,7 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
|
||||
-- | Error handling.
|
||||
module Language.GraphQL.Error
|
||||
( parseError
|
||||
, CollectErrsT
|
||||
|
|
|
@ -1,5 +1,7 @@
|
|||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
-- | @GraphQL@ document parser.
|
||||
module Language.GraphQL.Parser
|
||||
( document
|
||||
) where
|
||||
|
@ -67,7 +69,7 @@ alias = try $ name <* colon
|
|||
|
||||
-- * Arguments
|
||||
|
||||
arguments :: Parser Arguments
|
||||
arguments :: Parser [Argument]
|
||||
arguments = parens $ some argument
|
||||
|
||||
argument :: Parser Argument
|
||||
|
@ -133,7 +135,7 @@ objectField = ObjectField <$> name <* symbol ":" <*> value
|
|||
|
||||
-- * Variables
|
||||
|
||||
variableDefinitions :: Parser VariableDefinitions
|
||||
variableDefinitions :: Parser [VariableDefinition]
|
||||
variableDefinitions = parens $ some variableDefinition
|
||||
|
||||
variableDefinition :: Parser VariableDefinition
|
||||
|
@ -162,7 +164,7 @@ nonNullType = NonNullTypeNamed <$> name <* bang
|
|||
|
||||
-- * Directives
|
||||
|
||||
directives :: Parser Directives
|
||||
directives :: Parser [Directive]
|
||||
directives = some directive
|
||||
|
||||
directive :: Parser Directive
|
||||
|
|
|
@ -28,9 +28,7 @@ module Language.GraphQL.Schema
|
|||
import Control.Monad.IO.Class (MonadIO(..))
|
||||
import Control.Monad.Trans.Class (lift)
|
||||
import Control.Monad.Trans.Except (runExceptT)
|
||||
import Data.Foldable ( find
|
||||
, fold
|
||||
)
|
||||
import Data.Foldable (find, fold)
|
||||
import Data.List.NonEmpty (NonEmpty)
|
||||
import Data.Maybe (fromMaybe)
|
||||
import qualified Data.Aeson as Aeson
|
||||
|
@ -48,16 +46,13 @@ import Language.GraphQL.AST.Core
|
|||
-- @m@ is usually expected to be an instance of 'MonadIO'.
|
||||
type Schema m = NonEmpty (Resolver m)
|
||||
|
||||
-- | Resolves a 'Field' into an @Aeson.@'Aeson.Object' with error information
|
||||
-- (or 'empty'). @m@ is usually expected to be an instance of 'MonadIO.
|
||||
-- | Resolves a 'Field' into an @Aeson.@'Data.Aeson.Types.Object' with error
|
||||
-- information (if an error has occurred). @m@ is usually expected to be an
|
||||
-- instance of 'MonadIO'.
|
||||
data Resolver m = Resolver
|
||||
Text -- ^ Name
|
||||
(Field -> CollectErrsT m Aeson.Object) -- ^ Resolver
|
||||
|
||||
type Fields = [Field]
|
||||
|
||||
type Arguments = [Argument]
|
||||
|
||||
-- | Variable substitution function.
|
||||
type Subs = Name -> Maybe Value
|
||||
|
||||
|
@ -67,14 +62,14 @@ object name = objectA name . const
|
|||
|
||||
-- | Like 'object' but also taking 'Argument's.
|
||||
objectA :: MonadIO m
|
||||
=> Name -> (Arguments -> ActionT m [Resolver m]) -> Resolver m
|
||||
=> Name -> ([Argument] -> ActionT m [Resolver m]) -> Resolver m
|
||||
objectA name f = Resolver name $ resolveFieldValue f resolveRight
|
||||
where
|
||||
resolveRight fld@(Field _ _ _ flds) resolver = withField (resolve resolver flds) fld
|
||||
|
||||
-- | Like 'object' but also taking 'Argument's and can be null or a list of objects.
|
||||
wrappedObjectA :: MonadIO m
|
||||
=> Name -> (Arguments -> ActionT m (Wrapping [Resolver m])) -> Resolver m
|
||||
=> Name -> ([Argument] -> ActionT m (Wrapping [Resolver m])) -> Resolver m
|
||||
wrappedObjectA name f = Resolver name $ resolveFieldValue f resolveRight
|
||||
where
|
||||
resolveRight fld@(Field _ _ _ sels) resolver
|
||||
|
@ -91,14 +86,14 @@ scalar name = scalarA name . const
|
|||
|
||||
-- | Like 'scalar' but also taking 'Argument's.
|
||||
scalarA :: (MonadIO m, Aeson.ToJSON a)
|
||||
=> Name -> (Arguments -> ActionT m a) -> Resolver m
|
||||
=> Name -> ([Argument] -> ActionT m a) -> Resolver m
|
||||
scalarA name f = Resolver name $ resolveFieldValue f resolveRight
|
||||
where
|
||||
resolveRight fld result = withField (return result) fld
|
||||
|
||||
-- | Lika 'scalar' but also taking 'Argument's and can be null or a list of scalars.
|
||||
wrappedScalarA :: (MonadIO m, Aeson.ToJSON a)
|
||||
=> Name -> (Arguments -> ActionT m (Wrapping a)) -> Resolver m
|
||||
=> Name -> ([Argument] -> ActionT m (Wrapping a)) -> Resolver m
|
||||
wrappedScalarA name f = Resolver name $ resolveFieldValue f resolveRight
|
||||
where
|
||||
resolveRight fld (Named result) = withField (return result) fld
|
||||
|
@ -116,14 +111,14 @@ enum :: MonadIO m => Name -> ActionT m [Text] -> Resolver m
|
|||
enum name = enumA name . const
|
||||
|
||||
{-# DEPRECATED enumA "Use scalarA instead" #-}
|
||||
enumA :: MonadIO m => Name -> (Arguments -> ActionT m [Text]) -> Resolver m
|
||||
enumA :: MonadIO m => Name -> ([Argument] -> ActionT m [Text]) -> Resolver m
|
||||
enumA name f = Resolver name $ resolveFieldValue f resolveRight
|
||||
where
|
||||
resolveRight fld resolver = withField (return resolver) fld
|
||||
|
||||
{-# DEPRECATED wrappedEnumA "Use wrappedScalarA instead" #-}
|
||||
wrappedEnumA :: MonadIO m
|
||||
=> Name -> (Arguments -> ActionT m (Wrapping [Text])) -> Resolver m
|
||||
=> Name -> ([Argument] -> ActionT m (Wrapping [Text])) -> Resolver m
|
||||
wrappedEnumA name f = Resolver name $ resolveFieldValue f resolveRight
|
||||
where
|
||||
resolveRight fld (Named resolver) = withField (return resolver) fld
|
||||
|
@ -158,11 +153,21 @@ withField v fld
|
|||
-- 'Resolver' to each 'Field'. Resolves into a value containing the
|
||||
-- resolved 'Field', or a null value and error information.
|
||||
resolve :: MonadIO m
|
||||
=> [Resolver m] -> Fields -> CollectErrsT m Aeson.Value
|
||||
=> [Resolver m] -> [Selection] -> CollectErrsT m Aeson.Value
|
||||
resolve resolvers = fmap (Aeson.toJSON . fold) . traverse tryResolvers
|
||||
where
|
||||
tryResolvers fld = maybe (errmsg fld) (tryResolver fld) $ find (compareResolvers fld) resolvers
|
||||
compareResolvers (Field _ name _ _) (Resolver name' _) = name == name'
|
||||
resolveTypeName (Resolver "__typename" f) = do
|
||||
value <- f $ Field Nothing "__typename" mempty mempty
|
||||
return $ HashMap.lookupDefault "" "__typename" value
|
||||
resolveTypeName _ = return ""
|
||||
tryResolvers (SelectionField fld@(Field _ name _ _))
|
||||
= maybe (errmsg fld) (tryResolver fld) $ find (compareResolvers name) resolvers
|
||||
tryResolvers (SelectionFragment (Fragment typeCondition selections')) = do
|
||||
that <- maybe (return "") resolveTypeName (find (compareResolvers "__typename") resolvers)
|
||||
if Aeson.String typeCondition == that
|
||||
then fmap fold . traverse tryResolvers $ selections'
|
||||
else return mempty
|
||||
compareResolvers name (Resolver name' _) = name == name'
|
||||
tryResolver fld (Resolver _ resolver) = resolver fld
|
||||
errmsg fld@(Field _ name _ _) = do
|
||||
addErrMsg $ T.unwords ["field", name, "not resolved."]
|
||||
|
|
|
@ -1,3 +1,4 @@
|
|||
-- | Monad transformer stack used by the @GraphQL@ resolvers.
|
||||
module Language.GraphQL.Trans
|
||||
( ActionT(..)
|
||||
) where
|
||||
|
|
|
@ -1,6 +1,9 @@
|
|||
resolver: lts-14.5
|
||||
resolver: lts-14.11
|
||||
|
||||
packages:
|
||||
- '.'
|
||||
- .
|
||||
|
||||
extra-deps: []
|
||||
flags: {}
|
||||
extra-package-dbs: []
|
||||
|
||||
pvp-bounds: both
|
||||
|
|
|
@ -1,104 +1,92 @@
|
|||
{-# LANGUAGE ExplicitForAll #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
module Language.GraphQL.LexerSpec
|
||||
( spec
|
||||
) where
|
||||
|
||||
import Data.Either (isRight)
|
||||
import Data.Text (Text)
|
||||
import Data.Void (Void)
|
||||
import Language.GraphQL.Lexer
|
||||
import Test.Hspec ( Spec
|
||||
, context
|
||||
, describe
|
||||
, it
|
||||
, shouldBe
|
||||
, shouldSatisfy
|
||||
)
|
||||
import Text.Megaparsec ( ParseErrorBundle
|
||||
, parse
|
||||
)
|
||||
import Test.Hspec (Spec, context, describe, it)
|
||||
import Test.Hspec.Megaparsec (shouldParse, shouldSucceedOn)
|
||||
import Text.Megaparsec (ParseErrorBundle, parse)
|
||||
import Text.RawString.QQ (r)
|
||||
|
||||
spec :: Spec
|
||||
spec = describe "Lexer" $ do
|
||||
context "Reference tests" $ do
|
||||
it "accepts BOM header" $
|
||||
runParser unicodeBOM "\xfeff" `shouldSatisfy` isRight
|
||||
parse unicodeBOM "" `shouldSucceedOn` "\xfeff"
|
||||
|
||||
it "lexes strings" $ do
|
||||
runParser string [r|"simple"|] `shouldBe` Right "simple"
|
||||
runParser string [r|" white space "|] `shouldBe` Right " white space "
|
||||
runParser string [r|"quote \""|] `shouldBe` Right [r|quote "|]
|
||||
runParser string [r|"escaped \n"|] `shouldBe` Right "escaped \n"
|
||||
runParser string [r|"slashes \\ \/"|] `shouldBe` Right [r|slashes \ /|]
|
||||
runParser string [r|"unicode \u1234\u5678\u90AB\uCDEF"|]
|
||||
`shouldBe` Right "unicode ሴ噸邫췯"
|
||||
parse string "" [r|"simple"|] `shouldParse` "simple"
|
||||
parse string "" [r|" white space "|] `shouldParse` " white space "
|
||||
parse string "" [r|"quote \""|] `shouldParse` [r|quote "|]
|
||||
parse string "" [r|"escaped \n"|] `shouldParse` "escaped \n"
|
||||
parse string "" [r|"slashes \\ \/"|] `shouldParse` [r|slashes \ /|]
|
||||
parse string "" [r|"unicode \u1234\u5678\u90AB\uCDEF"|]
|
||||
`shouldParse` "unicode ሴ噸邫췯"
|
||||
|
||||
it "lexes block string" $ do
|
||||
runParser blockString [r|"""simple"""|] `shouldBe` Right "simple"
|
||||
runParser blockString [r|""" white space """|]
|
||||
`shouldBe` Right " white space "
|
||||
runParser blockString [r|"""contains " quote"""|]
|
||||
`shouldBe` Right [r|contains " quote|]
|
||||
runParser blockString [r|"""contains \""" triplequote"""|]
|
||||
`shouldBe` Right [r|contains """ triplequote|]
|
||||
runParser blockString "\"\"\"multi\nline\"\"\"" `shouldBe` Right "multi\nline"
|
||||
runParser blockString "\"\"\"multi\rline\r\nnormalized\"\"\""
|
||||
`shouldBe` Right "multi\nline\nnormalized"
|
||||
runParser blockString "\"\"\"multi\rline\r\nnormalized\"\"\""
|
||||
`shouldBe` Right "multi\nline\nnormalized"
|
||||
runParser blockString [r|"""unescaped \n\r\b\t\f\u1234"""|]
|
||||
`shouldBe` Right [r|unescaped \n\r\b\t\f\u1234|]
|
||||
runParser blockString [r|"""slashes \\ \/"""|]
|
||||
`shouldBe` Right [r|slashes \\ \/|]
|
||||
runParser blockString [r|"""
|
||||
parse blockString "" [r|"""simple"""|] `shouldParse` "simple"
|
||||
parse blockString "" [r|""" white space """|]
|
||||
`shouldParse` " white space "
|
||||
parse blockString "" [r|"""contains " quote"""|]
|
||||
`shouldParse` [r|contains " quote|]
|
||||
parse blockString "" [r|"""contains \""" triplequote"""|]
|
||||
`shouldParse` [r|contains """ triplequote|]
|
||||
parse blockString "" "\"\"\"multi\nline\"\"\"" `shouldParse` "multi\nline"
|
||||
parse blockString "" "\"\"\"multi\rline\r\nnormalized\"\"\""
|
||||
`shouldParse` "multi\nline\nnormalized"
|
||||
parse blockString "" "\"\"\"multi\rline\r\nnormalized\"\"\""
|
||||
`shouldParse` "multi\nline\nnormalized"
|
||||
parse blockString "" [r|"""unescaped \n\r\b\t\f\u1234"""|]
|
||||
`shouldParse` [r|unescaped \n\r\b\t\f\u1234|]
|
||||
parse blockString "" [r|"""slashes \\ \/"""|]
|
||||
`shouldParse` [r|slashes \\ \/|]
|
||||
parse blockString "" [r|"""
|
||||
|
||||
spans
|
||||
multiple
|
||||
lines
|
||||
|
||||
"""|] `shouldBe` Right "spans\n multiple\n lines"
|
||||
"""|] `shouldParse` "spans\n multiple\n lines"
|
||||
|
||||
it "lexes numbers" $ do
|
||||
runParser integer "4" `shouldBe` Right (4 :: Int)
|
||||
runParser float "4.123" `shouldBe` Right 4.123
|
||||
runParser integer "-4" `shouldBe` Right (-4 :: Int)
|
||||
runParser integer "9" `shouldBe` Right (9 :: Int)
|
||||
runParser integer "0" `shouldBe` Right (0 :: Int)
|
||||
runParser float "-4.123" `shouldBe` Right (-4.123)
|
||||
runParser float "0.123" `shouldBe` Right 0.123
|
||||
runParser float "123e4" `shouldBe` Right 123e4
|
||||
runParser float "123E4" `shouldBe` Right 123E4
|
||||
runParser float "123e-4" `shouldBe` Right 123e-4
|
||||
runParser float "123e+4" `shouldBe` Right 123e+4
|
||||
runParser float "-1.123e4" `shouldBe` Right (-1.123e4)
|
||||
runParser float "-1.123E4" `shouldBe` Right (-1.123E4)
|
||||
runParser float "-1.123e-4" `shouldBe` Right (-1.123e-4)
|
||||
runParser float "-1.123e+4" `shouldBe` Right (-1.123e+4)
|
||||
runParser float "-1.123e4567" `shouldBe` Right (-1.123e4567)
|
||||
parse integer "" "4" `shouldParse` (4 :: Int)
|
||||
parse float "" "4.123" `shouldParse` 4.123
|
||||
parse integer "" "-4" `shouldParse` (-4 :: Int)
|
||||
parse integer "" "9" `shouldParse` (9 :: Int)
|
||||
parse integer "" "0" `shouldParse` (0 :: Int)
|
||||
parse float "" "-4.123" `shouldParse` (-4.123)
|
||||
parse float "" "0.123" `shouldParse` 0.123
|
||||
parse float "" "123e4" `shouldParse` 123e4
|
||||
parse float "" "123E4" `shouldParse` 123E4
|
||||
parse float "" "123e-4" `shouldParse` 123e-4
|
||||
parse float "" "123e+4" `shouldParse` 123e+4
|
||||
parse float "" "-1.123e4" `shouldParse` (-1.123e4)
|
||||
parse float "" "-1.123E4" `shouldParse` (-1.123E4)
|
||||
parse float "" "-1.123e-4" `shouldParse` (-1.123e-4)
|
||||
parse float "" "-1.123e+4" `shouldParse` (-1.123e+4)
|
||||
parse float "" "-1.123e4567" `shouldParse` (-1.123e4567)
|
||||
|
||||
it "lexes punctuation" $ do
|
||||
runParser bang "!" `shouldBe` Right '!'
|
||||
runParser dollar "$" `shouldBe` Right '$'
|
||||
runBetween parens "()" `shouldSatisfy` isRight
|
||||
runParser spread "..." `shouldBe` Right "..."
|
||||
runParser colon ":" `shouldBe` Right ":"
|
||||
runParser equals "=" `shouldBe` Right "="
|
||||
runParser at "@" `shouldBe` Right '@'
|
||||
runBetween brackets "[]" `shouldSatisfy` isRight
|
||||
runBetween braces "{}" `shouldSatisfy` isRight
|
||||
runParser pipe "|" `shouldBe` Right "|"
|
||||
parse bang "" "!" `shouldParse` '!'
|
||||
parse dollar "" "$" `shouldParse` '$'
|
||||
runBetween parens `shouldSucceedOn` "()"
|
||||
parse spread "" "..." `shouldParse` "..."
|
||||
parse colon "" ":" `shouldParse` ":"
|
||||
parse equals "" "=" `shouldParse` "="
|
||||
parse at "" "@" `shouldParse` '@'
|
||||
runBetween brackets `shouldSucceedOn` "[]"
|
||||
runBetween braces `shouldSucceedOn` "{}"
|
||||
parse pipe "" "|" `shouldParse` "|"
|
||||
|
||||
context "Implementation tests" $ do
|
||||
it "lexes empty block strings" $
|
||||
runParser blockString [r|""""""|] `shouldBe` Right ""
|
||||
parse blockString "" [r|""""""|] `shouldParse` ""
|
||||
it "lexes ampersand" $
|
||||
runParser amp "&" `shouldBe` Right "&"
|
||||
|
||||
runParser :: forall a. Parser a -> Text -> Either (ParseErrorBundle Text Void) a
|
||||
runParser = flip parse ""
|
||||
parse amp "" "&" `shouldParse` "&"
|
||||
|
||||
runBetween :: (Parser () -> Parser ()) -> Text -> Either (ParseErrorBundle Text Void) ()
|
||||
runBetween parser = parse (parser $ pure ()) ""
|
||||
|
|
|
@ -4,27 +4,23 @@ module Language.GraphQL.ParserSpec
|
|||
( spec
|
||||
) where
|
||||
|
||||
import Data.Either (isRight)
|
||||
import Language.GraphQL.Parser (document)
|
||||
import Test.Hspec ( Spec
|
||||
, describe
|
||||
, it
|
||||
, shouldSatisfy
|
||||
)
|
||||
import Test.Hspec (Spec, describe, it)
|
||||
import Test.Hspec.Megaparsec (shouldSucceedOn)
|
||||
import Text.Megaparsec (parse)
|
||||
import Text.RawString.QQ (r)
|
||||
|
||||
spec :: Spec
|
||||
spec = describe "Parser" $ do
|
||||
it "accepts BOM header" $
|
||||
parse document "" "\xfeff{foo}" `shouldSatisfy` isRight
|
||||
parse document "" `shouldSucceedOn` "\xfeff{foo}"
|
||||
|
||||
it "accepts block strings as argument" $
|
||||
parse document "" [r|{
|
||||
parse document "" `shouldSucceedOn` [r|{
|
||||
hello(text: """Argument""")
|
||||
}|] `shouldSatisfy` isRight
|
||||
}|]
|
||||
|
||||
it "accepts strings as argument" $
|
||||
parse document "" [r|{
|
||||
parse document "" `shouldSucceedOn` [r|{
|
||||
hello(text: "Argument")
|
||||
}|] `shouldSatisfy` isRight
|
||||
}|]
|
||||
|
|
|
@ -0,0 +1,97 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
module Test.FragmentSpec
|
||||
( spec
|
||||
) where
|
||||
|
||||
import Data.Aeson (Value(..), object, (.=))
|
||||
import qualified Data.HashMap.Strict as HashMap
|
||||
import Data.List.NonEmpty (NonEmpty(..))
|
||||
import Data.Text (Text)
|
||||
import Language.GraphQL
|
||||
import qualified Language.GraphQL.Schema as Schema
|
||||
import Test.Hspec (Spec, describe, it, shouldBe, shouldNotSatisfy)
|
||||
import Text.RawString.QQ (r)
|
||||
|
||||
size :: Schema.Resolver IO
|
||||
size = Schema.scalar "size" $ return ("L" :: Text)
|
||||
|
||||
circumference :: Schema.Resolver IO
|
||||
circumference = Schema.scalar "circumference" $ return (60 :: Int)
|
||||
|
||||
garment :: Text -> Schema.Resolver IO
|
||||
garment typeName = Schema.object "garment" $ return
|
||||
[ if typeName == "Hat" then circumference else size
|
||||
, Schema.scalar "__typename" $ return typeName
|
||||
]
|
||||
|
||||
inlineQuery :: Text
|
||||
inlineQuery = [r|{
|
||||
garment {
|
||||
... on Hat {
|
||||
circumference
|
||||
}
|
||||
... on Shirt {
|
||||
size
|
||||
}
|
||||
}
|
||||
}|]
|
||||
|
||||
spec :: Spec
|
||||
spec = describe "Inline fragment executor" $ do
|
||||
it "chooses the first selection if the type matches" $ do
|
||||
actual <- graphql (garment "Hat" :| []) inlineQuery
|
||||
let expected = object
|
||||
[ "data" .= object
|
||||
[ "garment" .= object
|
||||
[ "circumference" .= (60 :: Int)
|
||||
]
|
||||
]
|
||||
]
|
||||
in actual `shouldBe` expected
|
||||
|
||||
it "chooses the last selection if the type matches" $ do
|
||||
actual <- graphql (garment "Shirt" :| []) inlineQuery
|
||||
let expected = object
|
||||
[ "data" .= object
|
||||
[ "garment" .= object
|
||||
[ "size" .= ("L" :: Text)
|
||||
]
|
||||
]
|
||||
]
|
||||
in actual `shouldBe` expected
|
||||
|
||||
it "embeds inline fragments without type" $ do
|
||||
let query = [r|{
|
||||
garment {
|
||||
circumference
|
||||
... {
|
||||
size
|
||||
}
|
||||
}
|
||||
}|]
|
||||
resolvers = Schema.object "garment" $ return [circumference, size]
|
||||
|
||||
actual <- graphql (resolvers :| []) query
|
||||
let expected = object
|
||||
[ "data" .= object
|
||||
[ "garment" .= object
|
||||
[ "circumference" .= (60 :: Int)
|
||||
, "size" .= ("L" :: Text)
|
||||
]
|
||||
]
|
||||
]
|
||||
in actual `shouldBe` expected
|
||||
|
||||
it "evaluates fragments on Query" $ do
|
||||
let query = [r|{
|
||||
... {
|
||||
size
|
||||
}
|
||||
}|]
|
||||
|
||||
actual <- graphql (size :| []) query
|
||||
actual `shouldNotSatisfy` hasErrors
|
||||
where
|
||||
hasErrors (Object object') = HashMap.member "errors" object'
|
||||
hasErrors _ = True
|
|
@ -6,19 +6,13 @@ module Test.KitchenSinkSpec
|
|||
|
||||
import qualified Data.Text.IO as Text.IO
|
||||
import qualified Data.Text.Lazy.IO as Text.Lazy.IO
|
||||
import qualified Data.Text.Lazy as Lazy (Text)
|
||||
import qualified Language.GraphQL.Encoder as Encoder
|
||||
import qualified Language.GraphQL.Parser as Parser
|
||||
import Paths_graphql (getDataFileName)
|
||||
import Test.Hspec ( Spec
|
||||
, describe
|
||||
, it
|
||||
)
|
||||
import Test.Hspec.Expectations ( expectationFailure
|
||||
, shouldBe
|
||||
)
|
||||
import Text.Megaparsec ( errorBundlePretty
|
||||
, parse
|
||||
)
|
||||
import Test.Hspec (Spec, describe, it)
|
||||
import Test.Hspec.Megaparsec (parseSatisfies)
|
||||
import Text.Megaparsec (parse)
|
||||
import Text.RawString.QQ (r)
|
||||
|
||||
spec :: Spec
|
||||
|
@ -26,17 +20,12 @@ spec = describe "Kitchen Sink" $ do
|
|||
it "minifies the query" $ do
|
||||
dataFileName <- getDataFileName "tests/data/kitchen-sink.graphql"
|
||||
minFileName <- getDataFileName "tests/data/kitchen-sink.min.graphql"
|
||||
actual <- Text.IO.readFile dataFileName
|
||||
expected <- Text.Lazy.IO.readFile minFileName
|
||||
|
||||
either
|
||||
(expectationFailure . errorBundlePretty)
|
||||
(flip shouldBe expected . Encoder.document Encoder.minified)
|
||||
$ parse Parser.document dataFileName actual
|
||||
shouldNormalize Encoder.minified dataFileName expected
|
||||
|
||||
it "pretty prints the query" $ do
|
||||
dataFileName <- getDataFileName "tests/data/kitchen-sink.graphql"
|
||||
actual <- Text.IO.readFile dataFileName
|
||||
let expected = [r|query queryName($foo: ComplexType, $site: Site = MOBILE) {
|
||||
whoever123is: node(id: [123, 456]) {
|
||||
id
|
||||
|
@ -70,7 +59,11 @@ fragment frag on Friend {
|
|||
}
|
||||
|]
|
||||
|
||||
either
|
||||
(expectationFailure . errorBundlePretty)
|
||||
(flip shouldBe expected . Encoder.document Encoder.pretty)
|
||||
$ parse Parser.document dataFileName actual
|
||||
shouldNormalize Encoder.pretty dataFileName expected
|
||||
|
||||
shouldNormalize :: Encoder.Formatter -> FilePath -> Lazy.Text -> IO ()
|
||||
shouldNormalize formatter dataFileName expected = do
|
||||
actual <- Text.IO.readFile dataFileName
|
||||
parse Parser.document dataFileName actual `parseSatisfies` condition
|
||||
where
|
||||
condition = (expected ==) . Encoder.document formatter
|
||||
|
|
Loading…
Reference in New Issue