Release 0.5.1.0

Fixes #17.

.gitignore

@@ -8,3 +8,4 @@
 .cabal-sandbox/
 cabal.sandbox.config
 cabal.project.local
+/graphql.cabal

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

graphql.cabal

@@ -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

package.yaml

@@ -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

semaphoreci.sh

@@ -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() {

src/Language/GraphQL/AST.hs

@@ -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
+data Definition
-                | DefinitionFragment  FragmentDefinition
+    = DefinitionOperation OperationDefinition
-                  deriving (Eq, Show)
+    | DefinitionFragment FragmentDefinition
+    deriving (Eq, Show)
 
 -- | Operation definition.
-data OperationDefinition = OperationSelectionSet SelectionSet
+data OperationDefinition
-                         | OperationDefinition   OperationType
+    = OperationSelectionSet SelectionSet
-                                                 (Maybe Name)
+    | OperationDefinition OperationType
-                                                 VariableDefinitions
+                          (Maybe Name)
-                                                 Directives
+                          [VariableDefinition]
-                                                 SelectionSet
+                          [Directive]
-                           deriving (Eq, Show)
+                          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.

src/Language/GraphQL/AST/Core.hs

@@ -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)
+    = Query (Maybe Text) (NonEmpty Selection)
-    | Mutation (Maybe Text) (NonEmpty Field)
+    | 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)

src/Language/GraphQL/AST/Transform.hs

@@ -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
+-- | Replaces a fragment name by a list of 'Core.Field'. If the name doesn't
---   empty list is returned.
+--   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)
+operation subs fr (Full.OperationDefinition Full.Query name _vars _dirs sels) =
-    = case operationType of
+    Core.Query name $ appendSelection subs fr sels
-        Full.Query -> Core.Query name <$> node
+operation subs fr (Full.OperationDefinition Full.Mutation name _vars _dirs sels) =
-        Full.Mutation -> Core.Mutation name <$> node
+    Core.Mutation name $ appendSelection subs fr sels
-  where
-    node = traverse (hush . selection subs fr) sels
 
 selection
   :: Schema.Subs
   -> Fragmenter
   -> Full.Selection
-  -> Either [Core.Field] Core.Field
+  -> Either [Core.Selection] Core.Selection
-selection subs fr (Full.SelectionField fld) =
+selection subs fr (Full.SelectionField fld)
-  Right $ field subs fr fld
+    = Right $ Core.SelectionField $ field subs fr fld
-selection _    fr (Full.SelectionFragmentSpread (Full.FragmentSpread n _dirs)) =
+selection _ fr (Full.SelectionFragmentSpread (Full.FragmentSpread name _))
-  Left $ fr n
+    = Left $ Core.SelectionField <$> fr name
-selection _ _  (Full.SelectionInlineFragment _)  =
+selection subs fr  (Full.SelectionInlineFragment fragment)
-  error "Inline fragments not supported yet"
+    | (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' =
+fragmentDefinition subs (Full.FragmentDefinition name _tc _dirs sels) name'
-  -- TODO: Support fragments within fragments. Fold instead of map.
+    | name == name' = selection' <$> do
-  if name == name'
+        selections <- NonEmpty.toList $ selection subs mempty <$> sels
-  then either id pure =<< NonEmpty.toList (selection subs mempty <$> sels)
+        either id pure selections
-  else empty
+    | 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.Selection -> [Core.Selection] -> [Core.Selection]
-    go (Full.SelectionFragmentSpread (Full.FragmentSpread name _dirs)) = (fr name <>)
+    go (Full.SelectionFragmentSpread (Full.FragmentSpread name _dirs)) = ((Core.SelectionField <$> fr name) <>)
-    go sel =  (either id pure (selection subs fr sel) <>)
+    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
+appendSelection ::
-hush = either (const Nothing) Just
+    Schema.Subs ->
+    Fragmenter ->
+    NonEmpty Full.Selection ->
+    NonEmpty Core.Selection
+appendSelection subs fr = NonEmpty.fromList
+    . foldr (either (++) (:) . selection subs fr) []

src/Language/GraphQL/Encoder.hs

@@ -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
+    -> Maybe Name
-     -> VariableDefinitions
+    -> [VariableDefinition]
-     -> Directives
+    -> [Directive]
-     -> SelectionSet
+    -> SelectionSet
-     -> Text
+    -> 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)
 

src/Language/GraphQL/Error.hs

@@ -1,5 +1,7 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RecordWildCards #-}
+
+-- | Error handling.
 module Language.GraphQL.Error
     ( parseError
     , CollectErrsT

src/Language/GraphQL/Parser.hs

@@ -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

src/Language/GraphQL/Schema.hs

@@ -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
+import Data.Foldable (find, fold)
-                     , 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
+-- | Resolves a 'Field' into an @Aeson.@'Data.Aeson.Types.Object' with error
---   (or 'empty'). @m@ is usually expected to be an instance of 'MonadIO.
+--   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
+    resolveTypeName (Resolver "__typename" f) = do
-    compareResolvers (Field _ name _ _) (Resolver name' _) = name == name'
+        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."]

src/Language/GraphQL/Trans.hs

@@ -1,3 +1,4 @@
+-- | Monad transformer stack used by the @GraphQL@ resolvers.
 module Language.GraphQL.Trans
     ( ActionT(..)
     ) where

stack.yaml

@@ -1,6 +1,9 @@
-resolver: lts-14.5
+resolver: lts-14.11
+
 packages:
-- '.'
+- .
+
 extra-deps: []
 flags: {}
-extra-package-dbs: []
+
+pvp-bounds: both

tests/Language/GraphQL/LexerSpec.hs

@@ -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
+import Test.Hspec (Spec, context, describe, it)
-                  , context
+import Test.Hspec.Megaparsec (shouldParse, shouldSucceedOn)
-                  , describe
+import Text.Megaparsec (ParseErrorBundle, parse)
-                  , it
-                  , shouldBe
-                  , shouldSatisfy
-                  )
-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"
+            parse string "" [r|"simple"|] `shouldParse` "simple"
-            runParser string [r|" white space "|] `shouldBe` Right " white space "
+            parse string "" [r|" white space "|] `shouldParse` " white space "
-            runParser string [r|"quote \""|] `shouldBe` Right [r|quote "|]
+            parse string "" [r|"quote \""|] `shouldParse` [r|quote "|]
-            runParser string [r|"escaped \n"|] `shouldBe` Right "escaped \n"
+            parse string "" [r|"escaped \n"|] `shouldParse` "escaped \n"
-            runParser string [r|"slashes \\ \/"|] `shouldBe` Right [r|slashes \ /|]
+            parse string "" [r|"slashes \\ \/"|] `shouldParse` [r|slashes \ /|]
-            runParser string [r|"unicode \u1234\u5678\u90AB\uCDEF"|]
+            parse string "" [r|"unicode \u1234\u5678\u90AB\uCDEF"|]
-                `shouldBe` Right "unicode ሴ噸邫췯"
+                `shouldParse` "unicode ሴ噸邫췯"
 
         it "lexes block string" $ do
-            runParser blockString [r|"""simple"""|] `shouldBe` Right "simple"
+            parse blockString "" [r|"""simple"""|] `shouldParse` "simple"
-            runParser blockString [r|""" white space """|]
+            parse blockString "" [r|""" white space """|]
-                `shouldBe` Right " white space "
+                `shouldParse` " white space "
-            runParser blockString [r|"""contains " quote"""|]
+            parse blockString "" [r|"""contains " quote"""|]
-                `shouldBe` Right [r|contains " quote|]
+                `shouldParse` [r|contains " quote|]
-            runParser blockString [r|"""contains \""" triplequote"""|]
+            parse blockString "" [r|"""contains \""" triplequote"""|]
-                `shouldBe` Right [r|contains """ triplequote|]
+                `shouldParse` [r|contains """ triplequote|]
-            runParser blockString "\"\"\"multi\nline\"\"\"" `shouldBe` Right "multi\nline"
+            parse blockString "" "\"\"\"multi\nline\"\"\"" `shouldParse` "multi\nline"
-            runParser blockString "\"\"\"multi\rline\r\nnormalized\"\"\""
+            parse blockString "" "\"\"\"multi\rline\r\nnormalized\"\"\""
-                `shouldBe` Right "multi\nline\nnormalized"
+                `shouldParse` "multi\nline\nnormalized"
-            runParser blockString "\"\"\"multi\rline\r\nnormalized\"\"\""
+            parse blockString "" "\"\"\"multi\rline\r\nnormalized\"\"\""
-                `shouldBe` Right "multi\nline\nnormalized"
+                `shouldParse` "multi\nline\nnormalized"
-            runParser blockString [r|"""unescaped \n\r\b\t\f\u1234"""|]
+            parse blockString "" [r|"""unescaped \n\r\b\t\f\u1234"""|]
-                `shouldBe` Right [r|unescaped \n\r\b\t\f\u1234|]
+                `shouldParse` [r|unescaped \n\r\b\t\f\u1234|]
-            runParser blockString [r|"""slashes \\ \/"""|]
+            parse blockString "" [r|"""slashes \\ \/"""|]
-                `shouldBe` Right [r|slashes \\ \/|]
+                `shouldParse` [r|slashes \\ \/|]
-            runParser blockString [r|"""
+            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)
+            parse integer "" "4" `shouldParse` (4 :: Int)
-            runParser float "4.123" `shouldBe` Right 4.123
+            parse float "" "4.123" `shouldParse` 4.123
-            runParser integer "-4" `shouldBe` Right (-4 :: Int)
+            parse integer "" "-4" `shouldParse` (-4 :: Int)
-            runParser integer "9" `shouldBe` Right (9 :: Int)
+            parse integer "" "9" `shouldParse` (9 :: Int)
-            runParser integer "0" `shouldBe` Right (0 :: Int)
+            parse integer "" "0" `shouldParse` (0 :: Int)
-            runParser float "-4.123" `shouldBe` Right (-4.123)
+            parse float "" "-4.123" `shouldParse` (-4.123)
-            runParser float "0.123" `shouldBe` Right 0.123
+            parse float "" "0.123" `shouldParse` 0.123
-            runParser float "123e4" `shouldBe` Right 123e4
+            parse float "" "123e4" `shouldParse` 123e4
-            runParser float "123E4" `shouldBe` Right 123E4
+            parse float "" "123E4" `shouldParse` 123E4
-            runParser float "123e-4" `shouldBe` Right 123e-4
+            parse float "" "123e-4" `shouldParse` 123e-4
-            runParser float "123e+4" `shouldBe` Right 123e+4
+            parse float "" "123e+4" `shouldParse` 123e+4
-            runParser float "-1.123e4" `shouldBe` Right (-1.123e4)
+            parse float "" "-1.123e4" `shouldParse` (-1.123e4)
-            runParser float "-1.123E4" `shouldBe` Right (-1.123E4)
+            parse float "" "-1.123E4" `shouldParse` (-1.123E4)
-            runParser float "-1.123e-4" `shouldBe` Right (-1.123e-4)
+            parse float "" "-1.123e-4" `shouldParse` (-1.123e-4)
-            runParser float "-1.123e+4" `shouldBe` Right (-1.123e+4)
+            parse float "" "-1.123e+4" `shouldParse` (-1.123e+4)
-            runParser float "-1.123e4567" `shouldBe` Right (-1.123e4567)
+            parse float "" "-1.123e4567" `shouldParse` (-1.123e4567)
 
         it "lexes punctuation" $ do
-            runParser bang "!" `shouldBe` Right '!'
+            parse bang "" "!" `shouldParse` '!'
-            runParser dollar "$" `shouldBe` Right '$'
+            parse dollar "" "$" `shouldParse` '$'
-            runBetween parens "()" `shouldSatisfy` isRight
+            runBetween parens `shouldSucceedOn` "()"
-            runParser spread "..." `shouldBe` Right "..."
+            parse spread "" "..." `shouldParse` "..."
-            runParser colon ":" `shouldBe` Right ":"
+            parse colon "" ":" `shouldParse` ":"
-            runParser equals "=" `shouldBe` Right "="
+            parse equals "" "=" `shouldParse` "="
-            runParser at "@" `shouldBe` Right '@'
+            parse at "" "@" `shouldParse` '@'
-            runBetween brackets "[]" `shouldSatisfy` isRight
+            runBetween brackets `shouldSucceedOn` "[]"
-            runBetween braces "{}" `shouldSatisfy` isRight
+            runBetween braces `shouldSucceedOn` "{}"
-            runParser pipe "|" `shouldBe` Right "|"
+            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 "&"
+            parse amp "" "&" `shouldParse` "&"
-
-runParser :: forall a. Parser a -> Text -> Either (ParseErrorBundle Text Void) a
-runParser = flip parse ""
 
 runBetween :: (Parser () -> Parser ()) -> Text -> Either (ParseErrorBundle Text Void) ()
 runBetween parser = parse (parser $ pure ()) ""

tests/Language/GraphQL/ParserSpec.hs

@@ -4,27 +4,23 @@ module Language.GraphQL.ParserSpec
     ( spec
     ) where
 
-import Data.Either (isRight)
 import Language.GraphQL.Parser (document)
-import Test.Hspec ( Spec
+import Test.Hspec (Spec, describe, it)
-                  , describe
+import Test.Hspec.Megaparsec (shouldSucceedOn)
-                  , it
-                  , shouldSatisfy
-                  )
 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
+            }|]

tests/Test/FragmentSpec.hs

@@ -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

tests/Test/KitchenSinkSpec.hs

@@ -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
+import Test.Hspec (Spec, describe, it)
-                  , describe
+import Test.Hspec.Megaparsec (parseSatisfies)
-                  , it
+import Text.Megaparsec (parse)
-                  )
-import Test.Hspec.Expectations ( expectationFailure
-                               , shouldBe
-                               )
-import Text.Megaparsec ( errorBundlePretty
-                       , 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
+        shouldNormalize Encoder.minified dataFileName expected
-            (expectationFailure . errorBundlePretty)
-            (flip shouldBe expected . Encoder.document Encoder.minified)
-            $ parse Parser.document dataFileName actual
 
     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
+        shouldNormalize Encoder.pretty dataFileName expected
-            (expectationFailure . errorBundlePretty)
+
-            (flip shouldBe expected . Encoder.document Encoder.pretty)
+shouldNormalize :: Encoder.Formatter -> FilePath -> Lazy.Text -> IO ()
-            $ parse Parser.document dataFileName actual
+shouldNormalize formatter dataFileName expected = do
+    actual <- Text.IO.readFile dataFileName
+    parse Parser.document dataFileName actual `parseSatisfies` condition
+      where
+        condition = (expected ==) . Encoder.document formatter