aboutsummaryrefslogtreecommitdiff
path: root/src/Language/GraphQL/Execute
diff options
context:
space:
mode:
Diffstat (limited to 'src/Language/GraphQL/Execute')
-rw-r--r--src/Language/GraphQL/Execute/Execution.hs23
-rw-r--r--src/Language/GraphQL/Execute/Transform.hs138
2 files changed, 73 insertions, 88 deletions
diff --git a/src/Language/GraphQL/Execute/Execution.hs b/src/Language/GraphQL/Execute/Execution.hs
index 71a2baa..9d588ca 100644
--- a/src/Language/GraphQL/Execute/Execution.hs
+++ b/src/Language/GraphQL/Execute/Execution.hs
@@ -27,8 +27,7 @@ import qualified Language.GraphQL.Execute.Transform as Transform
import qualified Language.GraphQL.Type as Type
import qualified Language.GraphQL.Type.In as In
import qualified Language.GraphQL.Type.Out as Out
-import Language.GraphQL.Type.Internal
-import Language.GraphQL.Type.Schema
+import qualified Language.GraphQL.Type.Internal as Internal
import Prelude hiding (null)
resolveFieldValue :: MonadCatch m
@@ -43,7 +42,7 @@ resolveFieldValue result args resolver =
=> ResolverException
-> CollectErrsT m Type.Value
handleFieldError e =
- addErr (Error (Text.pack $ displayException e) []) >> pure Type.Null
+ addErr (Error (Text.pack $ displayException e) [] []) >> pure Type.Null
context = Type.Context
{ Type.arguments = Type.Arguments args
, Type.values = result
@@ -60,7 +59,7 @@ collectFields objectType = foldl forEach Map.empty
in Map.insertWith (<>) responseKey (field :| []) groupedFields
forEach groupedFields (Transform.SelectionFragment selectionFragment)
| Transform.Fragment fragmentType fragmentSelectionSet <- selectionFragment
- , doesFragmentTypeApply fragmentType objectType =
+ , Internal.doesFragmentTypeApply fragmentType objectType =
let fragmentGroupedFieldSet = collectFields objectType fragmentSelectionSet
in Map.unionWith (<>) groupedFields fragmentGroupedFieldSet
| otherwise = groupedFields
@@ -69,15 +68,15 @@ aliasOrName :: forall m. Transform.Field m -> Name
aliasOrName (Transform.Field alias name _ _) = fromMaybe name alias
resolveAbstractType :: Monad m
- => AbstractType m
+ => Internal.AbstractType m
-> Type.Subs
-> CollectErrsT m (Maybe (Out.ObjectType m))
resolveAbstractType abstractType values'
| Just (Type.String typeName) <- HashMap.lookup "__typename" values' = do
types' <- gets types
case HashMap.lookup typeName types' of
- Just (ObjectType objectType) ->
- if instanceOf objectType abstractType
+ Just (Internal.ObjectType objectType) ->
+ if Internal.instanceOf objectType abstractType
then pure $ Just objectType
else pure Nothing
_ -> pure Nothing
@@ -124,25 +123,25 @@ completeValue outputType@(Out.EnumBaseType enumType) _ (Type.Enum enum) =
let Type.EnumType _ _ enumMembers = enumType
in if HashMap.member enum enumMembers
then coerceResult outputType $ Enum enum
- else addErrMsg "Value completion failed."
+ else addErrMsg "Enum value completion failed."
completeValue (Out.ObjectBaseType objectType) fields result =
executeSelectionSet result objectType $ mergeSelectionSets fields
completeValue (Out.InterfaceBaseType interfaceType) fields result
| Type.Object objectMap <- result = do
- let abstractType = AbstractInterfaceType interfaceType
+ let abstractType = Internal.AbstractInterfaceType interfaceType
concreteType <- resolveAbstractType abstractType objectMap
case concreteType of
Just objectType -> executeSelectionSet result objectType
$ mergeSelectionSets fields
- Nothing -> addErrMsg "Value completion failed."
+ Nothing -> addErrMsg "Interface value completion failed."
completeValue (Out.UnionBaseType unionType) fields result
| Type.Object objectMap <- result = do
- let abstractType = AbstractUnionType unionType
+ let abstractType = Internal.AbstractUnionType unionType
concreteType <- resolveAbstractType abstractType objectMap
case concreteType of
Just objectType -> executeSelectionSet result objectType
$ mergeSelectionSets fields
- Nothing -> addErrMsg "Value completion failed."
+ Nothing -> addErrMsg "Union value completion failed."
completeValue _ _ _ = addErrMsg "Value completion failed."
mergeSelectionSets :: MonadCatch m
diff --git a/src/Language/GraphQL/Execute/Transform.hs b/src/Language/GraphQL/Execute/Transform.hs
index 9c7ad0a..010899b 100644
--- a/src/Language/GraphQL/Execute/Transform.hs
+++ b/src/Language/GraphQL/Execute/Transform.hs
@@ -47,24 +47,23 @@ import Language.GraphQL.AST (Name)
import qualified Language.GraphQL.Execute.Coerce as Coerce
import qualified Language.GraphQL.Type.Definition as Definition
import qualified Language.GraphQL.Type as Type
-import qualified Language.GraphQL.Type.In as In
-import Language.GraphQL.Type.Internal
+import qualified Language.GraphQL.Type.Internal as Type
import qualified Language.GraphQL.Type.Out as Out
-import Language.GraphQL.Type.Schema
+import qualified Language.GraphQL.Type.Schema as Schema
-- | Associates a fragment name with a list of 'Field's.
data Replacement m = Replacement
{ fragments :: HashMap Full.Name (Fragment m)
, fragmentDefinitions :: FragmentDefinitions
, variableValues :: Type.Subs
- , types :: HashMap Full.Name (Type m)
+ , types :: HashMap Full.Name (Schema.Type m)
}
type FragmentDefinitions = HashMap Full.Name Full.FragmentDefinition
-- | Represents fragments and inline fragments.
data Fragment m
- = Fragment (CompositeType m) (Seq (Selection m))
+ = Fragment (Type.CompositeType m) (Seq (Selection m))
-- | Single selection element.
data Selection m
@@ -85,7 +84,7 @@ data Field m = Field
-- | Contains the operation to be executed along with its root type.
data Document m = Document
- (HashMap Full.Name (Type m)) (Out.ObjectType m) (Operation m)
+ (HashMap Full.Name (Schema.Type m)) (Out.ObjectType m) (Operation m)
data OperationDefinition = OperationDefinition
Full.OperationType
@@ -139,38 +138,9 @@ getOperation (Just operationName) operations
matchingName (OperationDefinition _ name _ _ _) =
name == Just operationName
-lookupInputType
- :: Full.Type
- -> HashMap.HashMap Full.Name (Type m)
- -> Maybe In.Type
-lookupInputType (Full.TypeNamed name) types =
- case HashMap.lookup name types of
- Just (ScalarType scalarType) ->
- Just $ In.NamedScalarType scalarType
- Just (EnumType enumType) ->
- Just $ In.NamedEnumType enumType
- Just (InputObjectType objectType) ->
- Just $ In.NamedInputObjectType objectType
- _ -> Nothing
-lookupInputType (Full.TypeList list) types
- = In.ListType
- <$> lookupInputType list types
-lookupInputType (Full.TypeNonNull (Full.NonNullTypeNamed nonNull)) types =
- case HashMap.lookup nonNull types of
- Just (ScalarType scalarType) ->
- Just $ In.NonNullScalarType scalarType
- Just (EnumType enumType) ->
- Just $ In.NonNullEnumType enumType
- Just (InputObjectType objectType) ->
- Just $ In.NonNullInputObjectType objectType
- _ -> Nothing
-lookupInputType (Full.TypeNonNull (Full.NonNullTypeList nonNull)) types
- = In.NonNullListType
- <$> lookupInputType nonNull types
-
coerceVariableValues :: Coerce.VariableValue a
=> forall m
- . HashMap Full.Name (Type m)
+ . HashMap Full.Name (Schema.Type m)
-> OperationDefinition
-> HashMap.HashMap Full.Name a
-> Either QueryError Type.Subs
@@ -180,10 +150,10 @@ coerceVariableValues types operationDefinition variableValues =
$ foldr forEach (Just HashMap.empty) variableDefinitions
where
forEach variableDefinition coercedValues = do
- let Full.VariableDefinition variableName variableTypeName defaultValue =
+ let Full.VariableDefinition variableName variableTypeName defaultValue _ =
variableDefinition
- let defaultValue' = constValue <$> defaultValue
- variableType <- lookupInputType variableTypeName types
+ let defaultValue' = constValue . Full.node <$> defaultValue
+ variableType <- Type.lookupInputType variableTypeName types
Coerce.matchFieldValues
coerceVariableValue'
@@ -207,19 +177,20 @@ constValue (Full.ConstList l) = Type.List $ constValue <$> l
constValue (Full.ConstObject o) =
Type.Object $ HashMap.fromList $ constObjectField <$> o
where
- constObjectField (Full.ObjectField key value') = (key, constValue value')
+ constObjectField Full.ObjectField{value = value', ..} =
+ (name, constValue $ Full.node value')
-- | Rewrites the original syntax tree into an intermediate representation used
-- for query execution.
document :: Coerce.VariableValue a
=> forall m
- . Schema m
+ . Type.Schema m
-> Maybe Full.Name
-> HashMap Full.Name a
-> Full.Document
-> Either QueryError (Document m)
document schema operationName subs ast = do
- let referencedTypes = collectReferencedTypes schema
+ let referencedTypes = Schema.types schema
(operations, fragmentTable) <- defragment ast
chosenOperation <- getOperation operationName operations
@@ -233,14 +204,14 @@ document schema operationName subs ast = do
}
case chosenOperation of
OperationDefinition Full.Query _ _ _ _ ->
- pure $ Document referencedTypes (query schema)
+ pure $ Document referencedTypes (Schema.query schema)
$ operation chosenOperation replacement
OperationDefinition Full.Mutation _ _ _ _
- | Just mutationType <- mutation schema ->
+ | Just mutationType <- Schema.mutation schema ->
pure $ Document referencedTypes mutationType
$ operation chosenOperation replacement
OperationDefinition Full.Subscription _ _ _ _
- | Just subscriptionType <- subscription schema ->
+ | Just subscriptionType <- Schema.subscription schema ->
pure $ Document referencedTypes subscriptionType
$ operation chosenOperation replacement
_ -> Left UnsupportedRootOperation
@@ -288,33 +259,47 @@ operation operationDefinition replacement
selection
:: Full.Selection
-> State (Replacement m) (Either (Seq (Selection m)) (Selection m))
-selection (Full.Field alias name arguments' directives' selections) =
- maybe (Left mempty) (Right . SelectionField) <$> do
- fieldArguments <- foldM go HashMap.empty arguments'
- fieldSelections <- appendSelection selections
- fieldDirectives <- Definition.selection <$> directives directives'
- let field' = Field alias name fieldArguments fieldSelections
- pure $ field' <$ fieldDirectives
+selection (Full.FieldSelection fieldSelection) =
+ maybe (Left mempty) (Right . SelectionField) <$> field fieldSelection
+selection (Full.FragmentSpreadSelection fragmentSelection)
+ = maybe (Left mempty) (Right . SelectionFragment)
+ <$> fragmentSpread fragmentSelection
+selection (Full.InlineFragmentSelection fragmentSelection) =
+ inlineFragment fragmentSelection
+
+field :: Full.Field -> State (Replacement m) (Maybe (Field m))
+field (Full.Field alias name arguments' directives' selections _) = do
+ fieldArguments <- foldM go HashMap.empty arguments'
+ fieldSelections <- appendSelection selections
+ fieldDirectives <- Definition.selection <$> directives directives'
+ let field' = Field alias name fieldArguments fieldSelections
+ pure $ field' <$ fieldDirectives
where
- go arguments (Full.Argument name' value') =
+ go arguments (Full.Argument name' (Full.Node value' _) _) =
inputField arguments name' value'
-selection (Full.FragmentSpread name directives') =
- maybe (Left mempty) (Right . SelectionFragment) <$> do
- spreadDirectives <- Definition.selection <$> directives directives'
- fragments' <- gets fragments
-
- fragmentDefinitions' <- gets fragmentDefinitions
- case HashMap.lookup name fragments' of
- Just definition -> lift $ pure $ definition <$ spreadDirectives
- Nothing
- | Just definition <- HashMap.lookup name fragmentDefinitions' -> do
- fragDef <- fragmentDefinition definition
- case fragDef of
- Just fragment -> lift $ pure $ fragment <$ spreadDirectives
- _ -> lift $ pure Nothing
- | otherwise -> lift $ pure Nothing
-selection (Full.InlineFragment type' directives' selections) = do
+fragmentSpread
+ :: Full.FragmentSpread
+ -> State (Replacement m) (Maybe (Fragment m))
+fragmentSpread (Full.FragmentSpread name directives' _) = do
+ spreadDirectives <- Definition.selection <$> directives directives'
+ fragments' <- gets fragments
+
+ fragmentDefinitions' <- gets fragmentDefinitions
+ case HashMap.lookup name fragments' of
+ Just definition -> lift $ pure $ definition <$ spreadDirectives
+ Nothing
+ | Just definition <- HashMap.lookup name fragmentDefinitions' -> do
+ fragDef <- fragmentDefinition definition
+ case fragDef of
+ Just fragment -> lift $ pure $ fragment <$ spreadDirectives
+ _ -> lift $ pure Nothing
+ | otherwise -> lift $ pure Nothing
+
+inlineFragment
+ :: Full.InlineFragment
+ -> State (Replacement m) (Either (Seq (Selection m)) (Selection m))
+inlineFragment (Full.InlineFragment type' directives' selections _) = do
fragmentDirectives <- Definition.selection <$> directives directives'
case fragmentDirectives of
Nothing -> pure $ Left mempty
@@ -325,7 +310,7 @@ selection (Full.InlineFragment type' directives' selections) = do
Nothing -> pure $ Left fragmentSelectionSet
Just typeName -> do
types' <- gets types
- case lookupTypeCondition typeName types' of
+ case Type.lookupTypeCondition typeName types' of
Just typeCondition -> pure $
selectionFragment typeCondition fragmentSelectionSet
Nothing -> pure $ Left mempty
@@ -346,10 +331,10 @@ appendSelection = foldM go mempty
directives :: [Full.Directive] -> State (Replacement m) [Definition.Directive]
directives = traverse directive
where
- directive (Full.Directive directiveName directiveArguments)
+ directive (Full.Directive directiveName directiveArguments _)
= Definition.Directive directiveName . Type.Arguments
<$> foldM go HashMap.empty directiveArguments
- go arguments (Full.Argument name value') = do
+ go arguments (Full.Argument name (Full.Node value' _) _) = do
substitutedValue <- value value'
return $ HashMap.insert name substitutedValue arguments
@@ -372,7 +357,7 @@ fragmentDefinition (Full.FragmentDefinition name type' _ selections _) = do
fragmentSelection <- appendSelection selections
types' <- gets types
- case lookupTypeCondition type' types' of
+ case Type.lookupTypeCondition type' types' of
Just compositeType -> do
let newValue = Fragment compositeType fragmentSelection
modify $ insertFragment newValue
@@ -399,7 +384,8 @@ value (Full.List list) = Type.List <$> traverse value list
value (Full.Object object) =
Type.Object . HashMap.fromList <$> traverse objectField object
where
- objectField (Full.ObjectField name value') = (name,) <$> value value'
+ objectField Full.ObjectField{value = value', ..} =
+ (name,) <$> value (Full.node value')
input :: forall m. Full.Value -> State (Replacement m) (Maybe Input)
input (Full.Variable name) =
@@ -415,8 +401,8 @@ input (Full.Object object) = do
objectFields <- foldM objectField HashMap.empty object
pure $ pure $ Object objectFields
where
- objectField resultMap (Full.ObjectField name value') =
- inputField resultMap name value'
+ objectField resultMap Full.ObjectField{value = value', ..} =
+ inputField resultMap name $ Full.node value'
inputField :: forall m
. HashMap Full.Name Input
generated by cgit v1.2.3 (git 2.26.2) at 2026-10-02 09:36:11 +0000