diff options
Diffstat (limited to 'src/Language/GraphQL/Execute/Transform.hs')
| -rw-r--r-- | src/Language/GraphQL/Execute/Transform.hs | 138 |
1 files changed, 62 insertions, 76 deletions
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 |