graphql 0.5.0.1 → 0.5.1.0

raw patch · 14 files changed

+324/−183 lines, 14 filesdep +hspec-megaparsecdep ~aesonPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: hspec-megaparsec

Dependency ranges changed: aeson

API changes (from Hackage documentation)

Files

• CHANGELOG.md +18/−0
• graphql.cabal +7/−4
• src/Language/GraphQL/AST.hs +22/−18
• src/Language/GraphQL/AST/Core.hs +20/−4
• src/Language/GraphQL/AST/Transform.hs +44/−28
• src/Language/GraphQL/Encoder.hs +8/−8
• src/Language/GraphQL/Error.hs +2/−0
• src/Language/GraphQL/Parser.hs +5/−3
• src/Language/GraphQL/Schema.hs +23/−18
• src/Language/GraphQL/Trans.hs +1/−0
• tests/Language/GraphQL/LexerSpec.hs +57/−69
• tests/Language/GraphQL/ParserSpec.hs +7/−11
• tests/Test/FragmentSpec.hs +97/−0
• tests/Test/KitchenSinkSpec.hs +13/−20

@@ -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 @@ ### 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,6 +1,6 @@ cabal-version: 1.12 name: graphql-version: 0.5.0.1+version: 0.5.1.0 license: BSD3 license-file: LICENSE copyright: (c) 2019 Eugen Wissner,@@ -48,7 +48,7 @@         Paths_graphql     default-language: Haskell2010     build-depends:-        aeson >=1.4.4.0 && <1.5,+        aeson >=1.4.5.0 && <1.5,         base >=4.7 && <5,         megaparsec >=7.0.5 && <7.1,         text >=1.2.3.1 && <1.3,@@ -64,6 +64,7 @@         Language.GraphQL.ErrorSpec         Language.GraphQL.LexerSpec         Language.GraphQL.ParserSpec+        Test.FragmentSpec         Test.KitchenSinkSpec         Test.StarWars.Data         Test.StarWars.QuerySpec@@ -72,12 +73,14 @@     default-language: Haskell2010     ghc-options: -threaded -rtsopts -with-rtsopts=-N     build-depends:-        aeson >=1.4.4.0 && <1.5,+        aeson >=1.4.5.0 && <1.5,         base >=4.7 && <5,         graphql -any,         hspec >=2.7.1 && <2.8,         hspec-expectations >=0.8.2 && <0.9,+        hspec-megaparsec >=2.0.1 && <2.1,         megaparsec >=7.0.5 && <7.1,         raw-strings-qq ==1.1.*,         text >=1.2.3.1 && <1.3,-        transformers >=0.5.6.2 && <0.6+        transformers >=0.5.6.2 && <0.6,+        unordered-containers >=0.2.10.0 && <0.3

@@ -35,6 +35,7 @@ import Data.Text (Text) import Language.GraphQL.AST.Core ( Alias                                  , Name+                                 , TypeCondition                                  )  -- * Document@@ -45,18 +46,20 @@ -- * 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 @@ -- | "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 @@  -- | 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 @@ -- * 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 @@ -- * Variables  -- | Variable definition list.+{-# DEPRECATED VariableDefinitions "Use [VariableDefinition] instead" #-} type VariableDefinitions = [VariableDefinition]  -- | Variable definition.@@ -157,6 +160,7 @@ -- * Directives  -- | Directive list.+{-# DEPRECATED Directives "Use [Directive] instead" #-} type Directives = [Directive]  -- | Directive.

@@ -4,16 +4,18 @@     , 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 @@ -- -- 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 @@ -- * "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 @@ -- -- 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 @@   -> 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 @@   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 @@ 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 @@     = 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 @@     = "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 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 @@  -- * Arguments -arguments :: Parser Arguments+arguments :: Parser [Argument] arguments = parens $ some argument  argument :: Parser Argument@@ -133,7 +135,7 @@  -- * Variables -variableDefinitions :: Parser VariableDefinitions+variableDefinitions :: Parser [VariableDefinition] variableDefinitions = parens $ some variableDefinition  variableDefinition :: Parser VariableDefinition@@ -162,7 +164,7 @@  -- * Directives -directives :: Parser Directives+directives :: Parser [Directive] directives = some directive  directive :: Parser Directive

@@ -28,9 +28,7 @@ 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 @@ --   @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 @@  -- | 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 @@  -- | 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 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 @@ --   '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,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 @@     ( 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 @@  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 @@     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 @@ } |] -        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