Add location information to the intermediate tree

2021-05-12 06:51:59 +02:00 · 2021-05-12 06:51:59 +02:00 · 1b7cd85216
commit 1b7cd85216
parent f671645043
4 changed files with 69 additions and 13 deletions
--- a/src/Language/GraphQL/Execute/Execution.hs
+++ b/src/Language/GraphQL/Execute/Execution.hs
@ -13,6 +13,7 @@ import Control.Monad.Trans.Class (lift)
 import Control.Monad.Trans.Reader (runReaderT)
 import Control.Monad.Trans.State (gets)
 import Data.List.NonEmpty (NonEmpty(..))
+import qualified Data.List.NonEmpty as NonEmpty
 import Data.HashMap.Strict (HashMap)
 import qualified Data.HashMap.Strict as HashMap
 import Data.Maybe (fromMaybe)
@ -66,7 +67,7 @@ collectFields objectType = foldl forEach OrderedMap.empty
        | otherwise = groupedFields

 aliasOrName :: forall m. Transform.Field m -> Name
-aliasOrName (Transform.Field alias name _ _) = fromMaybe name alias
+aliasOrName (Transform.Field alias name _ _ _) = fromMaybe name alias

 resolveAbstractType :: Monad m
    => Internal.AbstractType m
@ -96,7 +97,7 @@ executeField fieldResolver prev fields
  where
    executeField' fieldDefinition resolver = do
        let Out.Field _ fieldType argumentDefinitions = fieldDefinition
-        let (Transform.Field _ _ arguments' _ :| []) = fields
+        let (Transform.Field _ _ arguments' _ _ :| []) = fields
        case coerceArgumentValues argumentDefinitions arguments' of
            Nothing -> addError null $ Error "Argument coercing failed." [] []
            Just argumentValues -> do
@ -120,11 +121,12 @@ completeValue outputType@(Out.ScalarBaseType _) _ (Type.Float float) =
    coerceResult outputType $ Float float
 completeValue outputType@(Out.ScalarBaseType _) _ (Type.String string) =
    coerceResult outputType $ String string
-completeValue outputType@(Out.EnumBaseType enumType) _ (Type.Enum enum) =
+completeValue outputType@(Out.EnumBaseType enumType) fields (Type.Enum enum) =
    let Type.EnumType _ _ enumMembers = enumType
+        Transform.Field _ _ _ _ location = NonEmpty.head fields
     in if HashMap.member enum enumMembers
        then coerceResult outputType $ Enum enum
-        else addError null $ Error "Enum value completion failed." [] []
+        else addError null $ Error "Enum value completion failed." [location] []
 completeValue (Out.ObjectBaseType objectType) fields result =
    executeSelectionSet result objectType $ mergeSelectionSets fields
 completeValue (Out.InterfaceBaseType interfaceType) fields result
@ -139,12 +141,13 @@ completeValue (Out.InterfaceBaseType interfaceType) fields result
 completeValue (Out.UnionBaseType unionType) fields result
    | Type.Object objectMap <- result = do
        let abstractType = Internal.AbstractUnionType unionType
+        let Transform.Field _ _ _ _ location = NonEmpty.head fields
        concreteType <- resolveAbstractType abstractType objectMap
        case concreteType of
            Just objectType -> executeSelectionSet result objectType
                $ mergeSelectionSets fields
            Nothing -> addError null
-                $ Error "Union value completion failed." [] []
+                $ Error "Union value completion failed." [location] []
 completeValue _ _ _ = addError null $ Error "Value completion failed." [] []

 mergeSelectionSets :: MonadCatch m
@ -152,7 +155,7 @@ mergeSelectionSets :: MonadCatch m
    -> Seq (Transform.Selection m)
 mergeSelectionSets = foldr forEach mempty
  where
-    forEach (Transform.Field _ _ _ fieldSelectionSet) selectionSet =
+    forEach (Transform.Field _ _ _ fieldSelectionSet _) selectionSet =
        selectionSet <> fieldSelectionSet

 coerceResult :: (MonadCatch m, Serialize a)
@ -177,7 +180,7 @@ executeSelectionSet result objectType@(Out.ObjectType _ _ _ resolvers) selection
    coerceResult (Out.NonNullObjectType objectType) $ Object resolvedValues
  where
    forEach fields@(field :| _) =
-        let Transform.Field _ name _ _ = field
+        let Transform.Field _ name _ _ _ = field
         in traverse (tryResolver fields) $ lookupResolver name
    lookupResolver = flip HashMap.lookup resolvers
    tryResolver fields resolver =
--- a/src/Language/GraphQL/Execute/Subscribe.hs
+++ b/src/Language/GraphQL/Execute/Subscribe.hs
@ -52,7 +52,7 @@ createSourceEventStream :: MonadCatch m
    -> m (Either String (Out.SourceEventStream m))
 createSourceEventStream _types subscriptionType@(Out.ObjectType _ _ _ fieldTypes) fields
    | [fieldGroup] <- OrderedMap.elems groupedFieldSet
-    , Transform.Field _ fieldName arguments' _ <- NonEmpty.head fieldGroup
+    , Transform.Field _ fieldName arguments' _ _ <- NonEmpty.head fieldGroup
    , resolverT <- fieldTypes HashMap.! fieldName
    , Out.EventStreamResolver fieldDefinition _ resolver <- resolverT
    , Out.Field _ _fieldType argumentDefinitions <- fieldDefinition =
--- a/src/Language/GraphQL/Execute/Transform.hs
+++ b/src/Language/GraphQL/Execute/Transform.hs
@ -1,3 +1,7 @@
+{- This Source Code Form is subject to the terms of the Mozilla Public License,
+   v. 2.0. If a copy of the MPL was not distributed with this file, You can
+   obtain one at https://mozilla.org/MPL/2.0/. -}
+
 {-# LANGUAGE ExplicitForAll #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedStrings #-}
@ -77,7 +81,11 @@ data Operation m

 -- | Single GraphQL field.
 data Field m = Field
-    (Maybe Full.Name) Full.Name (HashMap Full.Name Input) (Seq (Selection m))
+    (Maybe Full.Name)
+    Full.Name
+    (HashMap Full.Name Input)
+    (Seq (Selection m))
+    Full.Location

 -- | Contains the operation to be executed along with its root type.
 data Document m = Document
@ -263,11 +271,11 @@ selection (Full.InlineFragmentSelection fragmentSelection) =
    inlineFragment fragmentSelection

 field :: Full.Field ->  State (Replacement m) (Maybe (Field m))
-field (Full.Field alias name arguments' directives' selections _) = do
+field (Full.Field alias name arguments' directives' selections location) = do
    fieldArguments <- foldM go HashMap.empty arguments'
    fieldSelections <- appendSelection selections
    fieldDirectives <- Definition.selection <$> directives directives'
-    let field' = Field alias name fieldArguments fieldSelections
+    let field' = Field alias name fieldArguments fieldSelections location
    pure $ field' <$ fieldDirectives
  where
    go arguments (Full.Argument name' (Full.Node value' _) _) =
--- a/tests/Language/GraphQL/ExecuteSpec.hs
+++ b/tests/Language/GraphQL/ExecuteSpec.hs
@ -15,7 +15,7 @@ import Data.Aeson.Types (emptyObject)
 import Data.Conduit
 import Data.HashMap.Strict (HashMap)
 import qualified Data.HashMap.Strict as HashMap
-import Language.GraphQL.AST (Document, Name)
+import Language.GraphQL.AST (Document, Location(..), Name)
 import Language.GraphQL.AST.Parser (document)
 import Language.GraphQL.Error
 import Language.GraphQL.Execute
@ -37,6 +37,29 @@ queryType = Out.ObjectType "Query" Nothing []
    philosopherField =
        Out.Field Nothing (Out.NonNullObjectType philosopherType) HashMap.empty

+musicType :: Out.ObjectType (Either SomeException)
+musicType = Out.ObjectType "Music" Nothing []
+    $ HashMap.fromList resolvers
+  where
+    resolvers =
+        [ ("instrument", ValueResolver instrumentField instrumentResolver)
+        ]
+    instrumentResolver = pure $ Type.String "piano"
+    instrumentField = Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty
+
+poetryType :: Out.ObjectType (Either SomeException)
+poetryType = Out.ObjectType "Poetry" Nothing []
+    $ HashMap.fromList resolvers
+  where
+    resolvers =
+        [ ("genre", ValueResolver genreField genreResolver)
+        ]
+    genreResolver = pure $ Type.String "Futurism"
+    genreField = Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty
+
+interestType :: Out.UnionType (Either SomeException)
+interestType = Out.UnionType "Interest" Nothing [musicType, poetryType]
+
 philosopherType :: Out.ObjectType (Either SomeException)
 philosopherType = Out.ObjectType "Philosopher" Nothing []
    $ HashMap.fromList resolvers
@ -45,6 +68,7 @@ philosopherType = Out.ObjectType "Philosopher" Nothing []
        [ ("firstName", ValueResolver firstNameField firstNameResolver)
        , ("lastName", ValueResolver lastNameField lastNameResolver)
        , ("school", ValueResolver schoolField schoolResolver)
+        , ("interest", ValueResolver interestField interestResolver)
        ]
    firstNameField =
        Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty
@ -55,6 +79,11 @@ philosopherType = Out.ObjectType "Philosopher" Nothing []
    schoolField
       = Out.Field Nothing (Out.NonNullEnumType schoolType) HashMap.empty
    schoolResolver = pure $ Type.Enum "EXISTENTIALISM"
+    interestField
+        = Out.Field Nothing (Out.NonNullUnionType interestType) HashMap.empty
+    interestResolver = pure
+        $ Type.Object
+        $ HashMap.fromList [("instrument", "piano")]

 subscriptionType :: Out.ObjectType (Either SomeException)
 subscriptionType = Out.ObjectType "Subscription" Nothing []
@ -138,7 +167,7 @@ spec =
                        ]
                    executionErrors = pure $ Error
                        { message = "Enum value completion failed."
-                        , locations = []
+                        , locations = [Location 1 17]
                        , path = []
                        }
                    expected = Response data'' executionErrors
@ -146,6 +175,22 @@ spec =
                        $ parse document "" "{ philosopher { school } }"
                in actual `shouldBe` expected

+            it "gives location information for invalid interfaces" $
+                let data'' = Aeson.object
+                        [ "philosopher" .= Aeson.object
+                            [ "interest" .= Aeson.Null
+                            ]
+                        ]
+                    executionErrors = pure $ Error
+                        { message = "Union value completion failed."
+                        , locations = [Location 1 17]
+                        , path = []
+                        }
+                    expected = Response data'' executionErrors
+                    Right (Right actual) = either (pure . parseError) execute'
+                        $ parse document "" "{ philosopher { interest } }"
+                in actual `shouldBe` expected
+
        context "Subscription" $
            it "subscribes" $
                let data'' = Aeson.object