Use directives from the Type module

This commit is contained in:
Eugen Wissner 2021-08-23 09:07:08 +02:00
parent 5e234ad4a9
commit 4f7e990bf9

View File

@ -3,6 +3,8 @@
obtain one at https://mozilla.org/MPL/2.0/. -} obtain one at https://mozilla.org/MPL/2.0/. -}
{-# LANGUAGE ExplicitForAll #-} {-# LANGUAGE ExplicitForAll #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
module Language.GraphQL.Executor module Language.GraphQL.Executor
@ -15,7 +17,8 @@ module Language.GraphQL.Executor
) where ) where
import Control.Monad.Trans.Class (MonadTrans(..)) import Control.Monad.Trans.Class (MonadTrans(..))
import Control.Monad.Trans.Reader (ReaderT(..), ask, runReader) import Control.Monad.Trans.Reader (ReaderT(..), ask, asks, runReader)
import Control.Monad (foldM)
import qualified Language.GraphQL.AST.Document as Full import qualified Language.GraphQL.AST.Document as Full
import qualified Data.Aeson as Aeson import qualified Data.Aeson as Aeson
import Data.Foldable (find) import Data.Foldable (find)
@ -120,13 +123,18 @@ data Selection
data Argument = Argument Full.Name (Full.Node Value) Full.Location data Argument = Argument Full.Name (Full.Node Value) Full.Location
data Field = data Field = Field
Field (Maybe Full.Name) Full.Name [Argument] [Directive] SelectionSet Full.Location (Maybe Full.Name)
Full.Name
[Argument]
[Type.Directive]
SelectionSet
Full.Location
data InlineFragment = InlineFragment data InlineFragment = InlineFragment
(Maybe Full.TypeCondition) [Directive] SelectionSet Full.Location (Maybe Full.TypeCondition) [Type.Directive] SelectionSet Full.Location
data FragmentSpread = FragmentSpread Full.Name [Directive] Full.Location data FragmentSpread = FragmentSpread Full.Name [Type.Directive] Full.Location
data Value data Value
= Variable Full.Name = Variable Full.Name
@ -145,8 +153,6 @@ data ObjectField = ObjectField
, location :: Full.Location , location :: Full.Location
} }
data Directive = Directive Full.Name [Argument] Full.Location
document :: Full.Document -> [Full.OperationDefinition] document :: Full.Document -> [Full.OperationDefinition]
document = foldr filterOperation [] document = foldr filterOperation []
where where
@ -178,24 +184,27 @@ selection (Full.InlineFragmentSelection inlineFragment') =
inlineFragment :: Full.InlineFragment -> Transform InlineFragment inlineFragment :: Full.InlineFragment -> Transform InlineFragment
inlineFragment (Full.InlineFragment typeCondition directives selectionSet' location) = do inlineFragment (Full.InlineFragment typeCondition directives selectionSet' location) = do
transformedSelections <- selectionSet selectionSet' transformedSelections <- selectionSet selectionSet'
transformedDirectives <- traverse directive directives
pure $ InlineFragment pure $ InlineFragment
typeCondition typeCondition
(directive <$> directives) transformedDirectives
transformedSelections transformedSelections
location location
fragmentSpread :: Full.FragmentSpread -> Transform FragmentSpread fragmentSpread :: Full.FragmentSpread -> Transform FragmentSpread
fragmentSpread (Full.FragmentSpread name' directives location) = fragmentSpread (Full.FragmentSpread name' directives location) = do
pure $ FragmentSpread name' (directive <$> directives) location transformedDirectives <- traverse directive directives
pure $ FragmentSpread name' transformedDirectives location
field :: Full.Field -> Transform Field field :: Full.Field -> Transform Field
field (Full.Field alias' name' arguments' directives' selectionSet' location') = do field (Full.Field alias' name' arguments' directives selectionSet' location') = do
transformedSelections <- traverse selection selectionSet' transformedSelections <- traverse selection selectionSet'
transformedDirectives <- traverse directive directives
pure $ Field pure $ Field
alias' alias'
name' name'
(argument <$> arguments') (argument <$> arguments')
(directive <$> directives') transformedDirectives
transformedSelections transformedSelections
location' location'
@ -203,9 +212,34 @@ argument :: Full.Argument -> Argument
argument (Full.Argument name' valueNode location') = argument (Full.Argument name' valueNode location') =
Argument name' (node valueNode) location' Argument name' (node valueNode) location'
directive :: Full.Directive -> Directive directive :: Full.Directive -> Transform Type.Directive
directive (Full.Directive name' arguments location') = directive (Full.Directive name' arguments _)
Directive name' (argument <$> arguments) location' = Type.Directive name'
. Type.Arguments
<$> foldM go HashMap.empty arguments
where
go accumulator (Full.Argument argumentName Full.Node{ node = node' } _) = do
transformedValue <- directiveValue node'
pure $ HashMap.insert argumentName transformedValue accumulator
directiveValue :: Full.Value -> Transform Type.Value
directiveValue = \case
(Full.Variable name') ->
TransformT $ asks (HashMap.lookupDefault Type.Null name')
(Full.Int integer) -> pure $ Type.Int integer
(Full.Float double) -> pure $ Type.Float double
(Full.String string) -> pure $ Type.String string
(Full.Boolean boolean) -> pure $ Type.Boolean boolean
Full.Null -> pure Type.Null
(Full.Enum enum) -> pure $ Type.Enum enum
(Full.List list) -> Type.List <$> traverse directiveNode list
(Full.Object objectFields) ->
Type.Object <$> foldM objectField HashMap.empty objectFields
where
directiveNode Full.Node{ node = node'} = directiveValue node'
objectField accumulator Full.ObjectField{ name, value } = do
transformedValue <- directiveNode value
pure $ HashMap.insert name transformedValue accumulator
variableValue :: Full.Value -> Value variableValue :: Full.Value -> Value
variableValue (Full.Variable name') = Variable name' variableValue (Full.Variable name') = Variable name'
@ -217,10 +251,7 @@ variableValue Full.Null = Null
variableValue (Full.Enum enum) = Enum enum variableValue (Full.Enum enum) = Enum enum
variableValue (Full.List list) = List $ node <$> list variableValue (Full.List list) = List $ node <$> list
variableValue (Full.Object objectFields) = Object $ objectField <$> objectFields variableValue (Full.Object objectFields) = Object $ objectField <$> objectFields
where
node :: Full.Node Full.Value -> Full.Node Value
node Full.Node{node = node', ..} = Full.Node (variableValue node') location
objectField :: Full.ObjectField Full.Value -> ObjectField objectField :: Full.ObjectField Full.Value -> ObjectField
objectField Full.ObjectField{..} = ObjectField objectField Full.ObjectField{..} = ObjectField
{ name = name { name = name
@ -228,6 +259,9 @@ objectField Full.ObjectField{..} = ObjectField
, location = location , location = location
} }
node :: Full.Node Full.Value -> Full.Node Value
node Full.Node{node = node', ..} = Full.Node (variableValue node') location
executeRequest :: Schema IO executeRequest :: Schema IO
-> Full.Document -> Full.Document
-> Maybe String -> Maybe String